Context Navigation

Back to Ticket #268

Ticket #268: distribute.F

File distribute.F, 132.5 KB (added by m.hadfield, 15 years ago)

Line
1	#include "cppdefs.h"
2	MODULE distribute_mod
3	#ifdef DISTRIBUTE
4
5	# define BOUNDARY_ALLREDUCE /* use mpi_allreduce in mp_boundary */
6	# undef COLLECT_ALLGATHER /* use mpi_allgather in mp_collect */
7	# define COLLECT_ALLREDUCE /* use mpi_allreduce in mp_collect */
8	# define REDUCE_ALLGATHER /* use mpi_allgather in mp_reduce */
9	# undef REDUCE_ALLREDUCE /* use mpi_allreduce in mp_reduce */
10	!
11	!svn $Id: distribute.F 294 2009-01-09 21:37:26Z arango $
12	!================================================== Hernan G. Arango ===
13	! Copyright (c) 2002-2009 The ROMS/TOMS Group !
14	! Licensed under a MIT/X style license !
15	! See License_ROMS.txt !
16	!=======================================================================
17	! !
18	! These routines are used for distrubuted-memory communications !
19	! between parallel nodes: !
20	! !
21	! mp_barrier barrier sychronization !
22	! mp_bcastf broadcast floating point variables !
23	! mp_bcasti broadcast integer variables !
24	! mp_bcastl broadcast local variable !
25	! mp_bcasts broadcast character variables !
26	! mp_boundary exchange boundary data between tiles !
27	! mp_collect collect 1D vector data from tiles !
28	! mp_dump writes 2D and 3D tiles arrays for debugging !
29	! mp_gather2d collect a 2D tiled array for output purposes !
30	! mp_gather3d collect a 3D tiled array for output purposes !
31	! mp_gather_state collect state vector for unpacking of variables !
32	! mp_ncread read in state vector/matrix from NetCDF file !
33	! mp_ncwrite write out state vector/matrix into NetCDF file !
34	! mp_reduce global reduction operations !
35	! mp_scatter2d scatter input data to a 2D tiled array !
36	! mp_scatter3d scatter input data to a 3D tiled array !
37	! mp_scatter_state scatter global data for packing of state vector !
38	! !
39	! Notice that the tile halo exchange can be found in "mp_exchange.F" !
40	! !
41	!=======================================================================
42	!
43	implicit none
44
45	INTERFACE mp_bcastf
46	MODULE PROCEDURE mp_bcastf_0d
47	MODULE PROCEDURE mp_bcastf_1d
48	MODULE PROCEDURE mp_bcastf_2d
49	MODULE PROCEDURE mp_bcastf_3d
50	MODULE PROCEDURE mp_bcastf_4d
51	END INTERFACE mp_bcastf
52
53	INTERFACE mp_bcastl
54	MODULE PROCEDURE mp_bcastl_0d
55	MODULE PROCEDURE mp_bcastl_1d
56	END INTERFACE mp_bcastl
57
58	INTERFACE mp_bcasti
59	MODULE PROCEDURE mp_bcasti_0d
60	MODULE PROCEDURE mp_bcasti_1d
61	MODULE PROCEDURE mp_bcasti_2d
62	END INTERFACE mp_bcasti
63
64	INTERFACE mp_bcasts
65	MODULE PROCEDURE mp_bcasts_0d
66	MODULE PROCEDURE mp_bcasts_1d
67	END INTERFACE mp_bcasts
68
69	INTERFACE mp_reduce
70	MODULE PROCEDURE mp_reduce_0d
71	MODULE PROCEDURE mp_reduce_1d
72	END INTERFACE mp_reduce
73
74	CONTAINS
75
76	SUBROUTINE mp_barrier (ng)
77	!
78	!***********************************************************************
79	! !
80	! This routine blocks the caller until all group members have called !
81	! it. !
82	! !
83	!***********************************************************************
84	!
85	USE mod_param
86	USE mod_parallel
87	!
88	implicit none
89	!
90	! Imported variable declarations.
91	!
92	integer, intent(in) :: ng
93	!
94	! Local variable declarations.
95	!
96	integer :: MyError
97	!
98	!-----------------------------------------------------------------------
99	! Synchronize all distribute-memory nodes in the group.
100	!-----------------------------------------------------------------------
101	!
102	# ifdef MPI
103	CALL mpi_barrier (OCN_COMM_WORLD, MyError)
104	# endif
105
106	RETURN
107	END SUBROUTINE mp_barrier
108
109	SUBROUTINE mp_bcastf_0d (ng, model, A)
110	!
111	!***********************************************************************
112	! !
113	! This routine broadcasts a floating-point scalar variable to all !
114	! processors the in group. It is called by all the members in the !
115	! group. !
116	! !
117	! On Input: !
118	! !
119	! ng Nested grid number. !
120	! model Calling model identifier. !
121	! A Variable to broadcast (real). !
122	! !
123	! On Output: !
124	! !
125	! A Broadcasted variable. !
126	! !
127	!***********************************************************************
128	!
129	USE mod_param
130	USE mod_parallel
131	USE mod_iounits
132	USE mod_scalars
133	!
134	implicit none
135	!
136	! Imported variable declarations.
137	!
138	integer, intent(in) :: ng, model
139
140	real(r8), intent(inout) :: A
141	!
142	! Local variable declarations
143	!
144	integer :: Lstr, MyError, Serror
145
146	character (len=MPI_MAX_ERROR_STRING) :: string
147
148	# ifdef PROFILE
149	!
150	!-----------------------------------------------------------------------
151	! Turn on time clocks.
152	!-----------------------------------------------------------------------
153	!
154	CALL wclock_on (ng, model, 42)
155	# endif
156	!
157	!-----------------------------------------------------------------------
158	! Broadcast requested variable.
159	!-----------------------------------------------------------------------
160	!
161	# ifdef MPI
162	CALL mpi_bcast (A, 1, MP_FLOAT, MyMaster, OCN_COMM_WORLD, MyError)
163	IF (MyError.ne.MPI_SUCCESS) THEN
164	CALL mpi_error_string (MyError, string, Lstr, Serror)
165	Lstr=LEN_TRIM(string)
166	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
167	10 FORMAT (/,' MP_BCASTF_0D - error during ',a,' call, Node = ', &
168	& i3.3,' Error = ',i3,/,13x,a)
169	exit_flag=2
170	RETURN
171	END IF
172	# endif
173	# ifdef PROFILE
174	!
175	!-----------------------------------------------------------------------
176	! Turn off time clocks.
177	!-----------------------------------------------------------------------
178	!
179	CALL wclock_off (ng, model, 42)
180	# endif
181
182	RETURN
183	END SUBROUTINE mp_bcastf_0d
184
185	SUBROUTINE mp_bcastf_1d (ng, model, A)
186	!
187	!***********************************************************************
188	! !
189	! This routine broadcasts a 1D floating-point, nontiled, array to !
190	! all processors processors in the group. It is called by all the !
191	! members in the group. !
192	! !
193	! On Input: !
194	! !
195	! ng Nested grid number. !
196	! model Calling model identifier. !
197	! A 1D array to broadcast (real). !
198	! !
199	! On Output: !
200	! !
201	! A Broadcasted 1D array. !
202	! !
203	!***********************************************************************
204	!
205	USE mod_param
206	USE mod_parallel
207	USE mod_iounits
208	USE mod_scalars
209	!
210	implicit none
211	!
212	! Imported variable declarations.
213	!
214	integer, intent(in) :: ng, model
215
216	real(r8), intent(inout) :: A(:)
217	!
218	! Local variable declarations
219	!
220	integer :: Lstr, MyError, Npts, Serror
221
222	character (len=MPI_MAX_ERROR_STRING) :: string
223
224	# ifdef PROFILE
225	!
226	!-----------------------------------------------------------------------
227	! Turn on time clocks.
228	!-----------------------------------------------------------------------
229	!
230	CALL wclock_on (ng, model, 42)
231	# endif
232	!
233	!-----------------------------------------------------------------------
234	! Broadcast requested variable.
235	!-----------------------------------------------------------------------
236	!
237	Npts=UBOUND(A, DIM=1)
238
239	# ifdef MPI
240	CALL mpi_bcast (A, Npts, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
241	& MyError)
242	IF (MyError.ne.MPI_SUCCESS) THEN
243	CALL mpi_error_string (MyError, string, Lstr, Serror)
244	Lstr=LEN_TRIM(string)
245	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
246	10 FORMAT (/,' MP_BCASTF_1D - error during ',a,' call, Node = ', &
247	& i3.3,' Error = ',i3,/,13x,a)
248	exit_flag=2
249	RETURN
250	END IF
251	# endif
252	# ifdef PROFILE
253	!
254	!-----------------------------------------------------------------------
255	! Turn off time clocks.
256	!-----------------------------------------------------------------------
257	!
258	CALL wclock_off (ng, model, 42)
259	# endif
260
261	RETURN
262	END SUBROUTINE mp_bcastf_1d
263
264	SUBROUTINE mp_bcastf_2d (ng, model, A)
265	!
266	!***********************************************************************
267	! !
268	! This routine broadcasts a 2D floating-point, nontiled, array to !
269	! all processors processors in the group. It is called by all the !
270	! members in the group. !
271	! !
272	! On Input: !
273	! !
274	! ng Nested grid number. !
275	! model Calling model identifier. !
276	! A 2D array to broadcast (real). !
277	! !
278	! On Output: !
279	! !
280	! A Broadcasted 2D array. !
281	! !
282	!***********************************************************************
283	!
284	USE mod_param
285	USE mod_parallel
286	USE mod_iounits
287	USE mod_scalars
288	!
289	implicit none
290	!
291	! Imported variable declarations.
292	!
293	integer, intent(in) :: ng, model
294
295	real(r8), intent(inout) :: A(:,:)
296	!
297	! Local variable declarations
298	!
299	integer :: Lstr, MyError, Npts, Serror
300
301	integer :: Asize(2)
302
303	character (len=MPI_MAX_ERROR_STRING) :: string
304
305	# ifdef PROFILE
306	!
307	!-----------------------------------------------------------------------
308	! Turn on time clocks.
309	!-----------------------------------------------------------------------
310	!
311	CALL wclock_on (ng, model, 42)
312	# endif
313	!
314	!-----------------------------------------------------------------------
315	! Broadcast requested variable.
316	!-----------------------------------------------------------------------
317	!
318	Asize(1)=UBOUND(A, DIM=1)
319	Asize(2)=UBOUND(A, DIM=2)
320	Npts=Asize(1)*Asize(2)
321
322	# ifdef MPI
323	CALL mpi_bcast (A, Npts, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
324	& MyError)
325	IF (MyError.ne.MPI_SUCCESS) THEN
326	CALL mpi_error_string (MyError, string, Lstr, Serror)
327	Lstr=LEN_TRIM(string)
328	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
329	10 FORMAT (/,' MP_BCASTF_2D - error during ',a,' call, Node = ', &
330	& i3.3,' Error = ',i3,/,13x,a)
331	exit_flag=2
332	RETURN
333	END IF
334	# endif
335	# ifdef PROFILE
336	!
337	!-----------------------------------------------------------------------
338	! Turn off time clocks.
339	!-----------------------------------------------------------------------
340	!
341	CALL wclock_off (ng, model, 42)
342	# endif
343
344	RETURN
345	END SUBROUTINE mp_bcastf_2d
346
347	SUBROUTINE mp_bcastf_3d (ng, model, A)
348	!
349	!***********************************************************************
350	! !
351	! This routine broadcasts a 3D floating-point, nontiled, array to !
352	! all processors processors in the group. It is called by all the !
353	! members in the group. !
354	! !
355	! On Input: !
356	! !
357	! ng Nested grid number. !
358	! model Calling model identifier. !
359	! A 3D array to broadcast (real). !
360	! !
361	! On Output: !
362	! !
363	! A Broadcasted 3D array. !
364	! !
365	!***********************************************************************
366	!
367	USE mod_param
368	USE mod_parallel
369	USE mod_iounits
370	USE mod_scalars
371	!
372	implicit none
373	!
374	! Imported variable declarations.
375	!
376	integer, intent(in) :: ng, model
377
378	real(r8), intent(inout) :: A(:,:,:)
379	!
380	! Local variable declarations
381	!
382	integer :: Lstr, MyError, Npts, Serror
383
384	integer :: Asize(3)
385
386	character (len=MPI_MAX_ERROR_STRING) :: string
387
388	# ifdef PROFILE
389	!
390	!-----------------------------------------------------------------------
391	! Turn on time clocks.
392	!-----------------------------------------------------------------------
393	!
394	CALL wclock_on (ng, model, 42)
395	# endif
396	!
397	!-----------------------------------------------------------------------
398	! Broadcast requested variable.
399	!-----------------------------------------------------------------------
400	!
401	Asize(1)=UBOUND(A, DIM=1)
402	Asize(2)=UBOUND(A, DIM=2)
403	Asize(3)=UBOUND(A, DIM=3)
404	Npts=Asize(1)Asize(2)Asize(3)
405
406	# ifdef MPI
407	CALL mpi_bcast (A, Npts, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
408	& MyError)
409	IF (MyError.ne.MPI_SUCCESS) THEN
410	CALL mpi_error_string (MyError, string, Lstr, Serror)
411	Lstr=LEN_TRIM(string)
412	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
413	10 FORMAT (/,' MP_BCASTF_3D - error during ',a,' call, Node = ', &
414	& i3.3,' Error = ',i3,/,13x,a)
415	exit_flag=2
416	RETURN
417	END IF
418	# endif
419	# ifdef PROFILE
420	!
421	!-----------------------------------------------------------------------
422	! Turn off time clocks.
423	!-----------------------------------------------------------------------
424	!
425	CALL wclock_off (ng, model, 42)
426	# endif
427
428	RETURN
429	END SUBROUTINE mp_bcastf_3d
430
431	SUBROUTINE mp_bcastf_4d (ng, model, A)
432	!
433	!***********************************************************************
434	! !
435	! This routine broadcasts a 4D floating-point, nontiled, array to !
436	! all processors processors in the group. It is called by all the !
437	! members in the group. !
438	! !
439	! On Input: !
440	! !
441	! ng Nested grid number. !
442	! model Calling model identifier. !
443	! A 4D array to broadcast (real). !
444	! !
445	! On Output: !
446	! !
447	! A Broadcasted 4D array. !
448	! !
449	!***********************************************************************
450	!
451	USE mod_param
452	USE mod_parallel
453	USE mod_iounits
454	USE mod_scalars
455	!
456	implicit none
457	!
458	! Imported variable declarations.
459	!
460	integer, intent(in) :: ng, model
461
462	real(r8), intent(inout) :: A(:,:,:,:)
463	!
464	! Local variable declarations
465	!
466	integer :: Lstr, MyError, Npts, Serror
467
468	integer :: Asize(4)
469
470	character (len=MPI_MAX_ERROR_STRING) :: string
471
472	# ifdef PROFILE
473	!
474	!-----------------------------------------------------------------------
475	! Turn on time clocks.
476	!-----------------------------------------------------------------------
477	!
478	CALL wclock_on (ng, model, 42)
479	# endif
480	!
481	!-----------------------------------------------------------------------
482	! Broadcast requested variable.
483	!-----------------------------------------------------------------------
484	!
485	Asize(1)=UBOUND(A, DIM=1)
486	Asize(2)=UBOUND(A, DIM=2)
487	Asize(3)=UBOUND(A, DIM=3)
488	Asize(4)=UBOUND(A, DIM=4)
489	Npts=Asize(1)Asize(2)Asize(3)*Asize(4)
490
491	# ifdef MPI
492	CALL mpi_bcast (A, Npts, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
493	& MyError)
494	IF (MyError.ne.MPI_SUCCESS) THEN
495	CALL mpi_error_string (MyError, string, Lstr, Serror)
496	Lstr=LEN_TRIM(string)
497	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
498	10 FORMAT (/,' MP_BCASTF_4D - error during ',a,' call, Node = ', &
499	& i3.3,' Error = ',i3,/,13x,a)
500	exit_flag=2
501	RETURN
502	END IF
503	# endif
504	# ifdef PROFILE
505	!
506	!-----------------------------------------------------------------------
507	! Turn off time clocks.
508	!-----------------------------------------------------------------------
509	!
510	CALL wclock_off (ng, model, 42)
511	# endif
512
513	RETURN
514	END SUBROUTINE mp_bcastf_4d
515
516	SUBROUTINE mp_bcasti_0d (ng, model, A)
517	!
518	!***********************************************************************
519	! !
520	! This routine broadcasts an integer scalar variable to all !
521	! processors the in group. It is called by all the members !
522	! in the group. !
523	! !
524	! On Input: !
525	! !
526	! ng Nested grid number. !
527	! model Calling model identifier. !
528	! A Variable to broadcast (integer). !
529	! !
530	! On Output: !
531	! !
532	! A Broadcasted variable. !
533	! !
534	!***********************************************************************
535	!
536	USE mod_param
537	USE mod_parallel
538	USE mod_iounits
539	!
540	implicit none
541	!
542	! Imported variable declarations.
543	!
544	integer, intent(in) :: ng, model
545
546	integer, intent(inout) :: A
547	!
548	! Local variable declarations
549	!
550	integer :: Lstr, MyError, Serror
551
552	character (len=MPI_MAX_ERROR_STRING) :: string
553
554	# ifdef PROFILE
555	!
556	!-----------------------------------------------------------------------
557	! Turn on time clocks.
558	!-----------------------------------------------------------------------
559	!
560	CALL wclock_on (ng, model, 42)
561	# endif
562	!
563	!-----------------------------------------------------------------------
564	! Broadcast requested variable.
565	!-----------------------------------------------------------------------
566	!
567	# ifdef MPI
568	CALL mpi_bcast (A, 1, MPI_INTEGER, MyMaster, OCN_COMM_WORLD, &
569	& MyError)
570	IF (MyError.ne.MPI_SUCCESS) THEN
571	CALL mpi_error_string (MyError, string, Lstr, Serror)
572	Lstr=LEN_TRIM(string)
573	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
574	10 FORMAT (/,' MP_BCASTI_0D - error during ',a,' call, Node = ', &
575	& i3.3,' Error = ',i3,/,13x,a)
576	RETURN
577	END IF
578	# endif
579	# ifdef PROFILE
580	!
581	!-----------------------------------------------------------------------
582	! Turn off time clocks.
583	!-----------------------------------------------------------------------
584	!
585	CALL wclock_off (ng, model, 42)
586	# endif
587
588	RETURN
589	END SUBROUTINE mp_bcasti_0d
590
591	SUBROUTINE mp_bcasti_1d (ng, model, A)
592	!
593	!***********************************************************************
594	! !
595	! This routine broadcasts a 1D nontiled, integer array to all 1
596	! processors processors in the group. It is called by all the !
597	! members in the group. !
598	! !
599	! On Input: !
600	! !
601	! ng Nested grid number. !
602	! model Calling model identifier. !
603	! A 1D array to broadcast (integer). !
604	! !
605	! On Output: !
606	! !
607	! A Broadcasted 1D array. !
608	! !
609	!***********************************************************************
610	!
611	USE mod_param
612	USE mod_parallel
613	USE mod_iounits
614	USE mod_scalars
615	!
616	implicit none
617	!
618	! Imported variable declarations.
619	!
620	integer, intent(in) :: ng, model
621
622	integer, intent(inout) :: A(:)
623	!
624	! Local variable declarations
625	!
626	integer :: Lstr, MyError, Npts, Serror
627
628	character (len=MPI_MAX_ERROR_STRING) :: string
629
630	# ifdef PROFILE
631	!
632	!-----------------------------------------------------------------------
633	! Turn on time clocks.
634	!-----------------------------------------------------------------------
635	!
636	CALL wclock_on (ng, model, 42)
637	# endif
638	!
639	!-----------------------------------------------------------------------
640	! Broadcast requested variable.
641	!-----------------------------------------------------------------------
642	!
643	Npts=UBOUND(A, DIM=1)
644
645	# ifdef MPI
646	CALL mpi_bcast (A, Npts, MPI_INTEGER, MyMaster, OCN_COMM_WORLD, &
647	& MyError)
648	IF (MyError.ne.MPI_SUCCESS) THEN
649	CALL mpi_error_string (MyError, string, Lstr, Serror)
650	Lstr=LEN_TRIM(string)
651	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
652	10 FORMAT (/,' MP_BCASTI_1D - error during ',a,' call, Node = ', &
653	& i3.3,' Error = ',i3,/,13x,a)
654	exit_flag=2
655	RETURN
656	END IF
657	# endif
658	# ifdef PROFILE
659	!
660	!-----------------------------------------------------------------------
661	! Turn off time clocks.
662	!-----------------------------------------------------------------------
663	!
664	CALL wclock_off (ng, model, 42)
665	# endif
666
667	RETURN
668	END SUBROUTINE mp_bcasti_1d
669
670	SUBROUTINE mp_bcasti_2d (ng, model, A)
671	!
672	!***********************************************************************
673	! !
674	! This routine broadcasts a 2D nontiled, integer array to all 1
675	! processors processors in the group. It is called by all the !
676	! members in the group. !
677	! !
678	! On Input: !
679	! !
680	! ng Nested grid number. !
681	! model Calling model identifier. !
682	! A 2D array to broadcast (integer). !
683	! !
684	! On Output: !
685	! !
686	! A Broadcasted 2D array. !
687	! !
688	!***********************************************************************
689	!
690	USE mod_param
691	USE mod_parallel
692	USE mod_iounits
693	USE mod_scalars
694	!
695	implicit none
696	!
697	! Imported variable declarations.
698	!
699	integer, intent(in) :: ng, model
700
701	integer, intent(inout) :: A(:,:)
702	!
703	! Local variable declarations
704	!
705	integer :: Lstr, MyError, Npts, Serror
706	integer :: Asize(2)
707
708	character (len=MPI_MAX_ERROR_STRING) :: string
709
710	# ifdef PROFILE
711	!
712	!-----------------------------------------------------------------------
713	! Turn on time clocks.
714	!-----------------------------------------------------------------------
715	!
716	CALL wclock_on (ng, model, 42)
717	# endif
718	!
719	!-----------------------------------------------------------------------
720	! Broadcast requested variable.
721	!-----------------------------------------------------------------------
722	!
723	Asize(1)=UBOUND(A, DIM=1)
724	Asize(2)=UBOUND(A, DIM=2)
725	Npts=Asize(1)*Asize(2)
726
727	# ifdef MPI
728	CALL mpi_bcast (A, Npts, MPI_INTEGER, MyMaster, OCN_COMM_WORLD, &
729	& MyError)
730	IF (MyError.ne.MPI_SUCCESS) THEN
731	CALL mpi_error_string (MyError, string, Lstr, Serror)
732	Lstr=LEN_TRIM(string)
733	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
734	10 FORMAT (/,' MP_BCASTI_2D - error during ',a,' call, Node = ', &
735	& i3.3,' Error = ',i3,/,13x,a)
736	exit_flag=2
737	RETURN
738	END IF
739	# endif
740	# ifdef PROFILE
741	!
742	!-----------------------------------------------------------------------
743	! Turn off time clocks.
744	!-----------------------------------------------------------------------
745	!
746	CALL wclock_off (ng, model, 42)
747	# endif
748
749	RETURN
750	END SUBROUTINE mp_bcasti_2d
751
752	SUBROUTINE mp_bcastl_0d (ng, model, A)
753	!
754	!***********************************************************************
755	! !
756	! This routine broadcasts a logical scalar variable to all !
757	! processors the in group. It is called by all the members !
758	! in the group. !
759	! !
760	! On Input: !
761	! !
762	! ng Nested grid number. !
763	! model Calling model identifier. !
764	! A Variable to broadcast (logical). !
765	! !
766	! On Output: !
767	! !
768	! A Broadcasted variable. !
769	! !
770	!***********************************************************************
771	!
772	USE mod_param
773	USE mod_parallel
774	USE mod_iounits
775	USE mod_scalars
776	!
777	implicit none
778	!
779	! Imported variable declarations.
780	!
781	integer, intent(in) :: ng, model
782
783	logical, intent(inout) :: A
784	!
785	! Local variable declarations
786	!
787	integer :: Lstr, MyError, Serror
788
789	character (len=MPI_MAX_ERROR_STRING) :: string
790
791	# ifdef PROFILE
792	!
793	!-----------------------------------------------------------------------
794	! Turn on time clocks.
795	!-----------------------------------------------------------------------
796	!
797	CALL wclock_on (ng, model, 42)
798	# endif
799	!
800	!-----------------------------------------------------------------------
801	! Broadcast requested variable.
802	!-----------------------------------------------------------------------
803	!
804	# ifdef MPI
805	CALL mpi_bcast (A, 1, MPI_LOGICAL, MyMaster, OCN_COMM_WORLD, &
806	& MyError)
807	IF (MyError.ne.MPI_SUCCESS) THEN
808	CALL mpi_error_string (MyError, string, Lstr, Serror)
809	Lstr=LEN_TRIM(string)
810	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
811	10 FORMAT (/,' MP_BCASTL_0D - error during ',a,' call, Node = ', &
812	& i3.3,' Error = ',i3,/,13x,a)
813	exit_flag=2
814	RETURN
815	END IF
816	# endif
817	# ifdef PROFILE
818	!
819	!-----------------------------------------------------------------------
820	! Turn off time clocks.
821	!-----------------------------------------------------------------------
822	!
823	CALL wclock_off (ng, model, 42)
824	# endif
825
826	RETURN
827	END SUBROUTINE mp_bcastl_0d
828
829	SUBROUTINE mp_bcastl_1d (ng, model, A)
830	!
831	!***********************************************************************
832	! !
833	! This routine broadcasts a 1D nontiled, logical array to all !
834	! processors processors in the group. It is called by all the !
835	! members in the group. !
836	! !
837	! On Input: !
838	! !
839	! ng Nested grid number. !
840	! model Calling model identifier. !
841	! A 1D array to broadcast (logical). !
842	! !
843	! On Output: !
844	! !
845	! A Broadcasted 1D array. !
846	! !
847	!***********************************************************************
848	!
849	USE mod_param
850	USE mod_parallel
851	USE mod_iounits
852	USE mod_scalars
853	!
854	implicit none
855	!
856	! Imported variable declarations.
857	!
858	integer, intent(in) :: ng, model
859
860	logical, intent(inout) :: A(:)
861	!
862	! Local variable declarations
863	!
864	integer :: Lstr, MyError, Npts, Serror
865
866	character (len=MPI_MAX_ERROR_STRING) :: string
867
868	# ifdef PROFILE
869	!
870	!-----------------------------------------------------------------------
871	! Turn on time clocks.
872	!-----------------------------------------------------------------------
873	!
874	CALL wclock_on (ng, model, 42)
875	# endif
876	!
877	!-----------------------------------------------------------------------
878	! Broadcast requested variable.
879	!-----------------------------------------------------------------------
880	!
881	Npts=UBOUND(A, DIM=1)
882
883	# ifdef MPI
884	CALL mpi_bcast (A, Npts, MPI_LOGICAL, MyMaster, OCN_COMM_WORLD, &
885	& MyError)
886	IF (MyError.ne.MPI_SUCCESS) THEN
887	CALL mpi_error_string (MyError, string, Lstr, Serror)
888	Lstr=LEN_TRIM(string)
889	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
890	10 FORMAT (/,' MP_BCASTL_1D - error during ',a,' call, Node = ', &
891	& i3.3,' Error = ',i3,/,13x,a)
892	exit_flag=2
893	RETURN
894	END IF
895	# endif
896	# ifdef PROFILE
897	!
898	!-----------------------------------------------------------------------
899	! Turn off time clocks.
900	!-----------------------------------------------------------------------
901	!
902	CALL wclock_off (ng, model, 42)
903	# endif
904
905	RETURN
906	END SUBROUTINE mp_bcastl_1d
907
908	SUBROUTINE mp_bcasts_0d (ng, model, A)
909	!
910	!***********************************************************************
911	! !
912	! This routine broadcasts a string scalar variable to all processors !
913	! in the group. It is called by all the members in the group. !
914	! !
915	! On Input: !
916	! !
917	! ng Nested grid number. !
918	! model Calling model identifier. !
919	! A Variable to broadcast (string). !
920	! !
921	! On Output: !
922	! !
923	! A Broadcasted variable. !
924	! !
925	!***********************************************************************
926	!
927	USE mod_param
928	USE mod_parallel
929	USE mod_iounits
930	USE mod_scalars
931	!
932	implicit none
933	!
934	! Imported variable declarations.
935	!
936	integer, intent(in) :: ng, model
937
938	character (len=*), intent(inout) :: A
939	!
940	! Local variable declarations
941	!
942	integer :: Lstr, MyError, Nchars, Serror
943
944	character (len=MPI_MAX_ERROR_STRING) :: string
945
946	# ifdef PROFILE
947	!
948	!-----------------------------------------------------------------------
949	! Turn on time clocks.
950	!-----------------------------------------------------------------------
951	!
952	CALL wclock_on (ng, model, 42)
953	# endif
954	!
955	!-----------------------------------------------------------------------
956	! Broadcast requested variable.
957	!-----------------------------------------------------------------------
958	!
959	Nchars=LEN(A)
960	# ifdef MPI
961	CALL mpi_bcast (A, Nchars, MPI_BYTE, MyMaster, OCN_COMM_WORLD, &
962	& MyError)
963	IF (MyError.ne.MPI_SUCCESS) THEN
964	CALL mpi_error_string (MyError, string, Lstr, Serror)
965	Lstr=LEN_TRIM(string)
966	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
967	10 FORMAT (/,' MP_BCASTS_0D - error during ',a,' call, Node = ', &
968	& i3.3,' Error = ',i3,/,13x,a)
969	exit_flag=2
970	RETURN
971	END IF
972	# endif
973	# ifdef PROFILE
974	!
975	!-----------------------------------------------------------------------
976	! Turn off time clocks.
977	!-----------------------------------------------------------------------
978	!
979	CALL wclock_off (ng, model, 42)
980	# endif
981
982	RETURN
983	END SUBROUTINE mp_bcasts_0d
984
985	SUBROUTINE mp_bcasts_1d (ng, model, A)
986	!
987	!***********************************************************************
988	! !
989	! This routine broadcasts a 1D nontiled, string array to all !
990	! processors processors in the group. It is called by all the !
991	! members in the group. !
992	! !
993	! On Input: !
994	! !
995	! ng Nested grid number. !
996	! model Calling model identifier. !
997	! A 1D array to broadcast (string). !
998	! !
999	! On Output: !
1000	! !
1001	! A Broadcasted 1D array. !
1002	! !
1003	!***********************************************************************
1004	!
1005	USE mod_param
1006	USE mod_parallel
1007	USE mod_iounits
1008	USE mod_scalars
1009	!
1010	implicit none
1011	!
1012	! Imported variable declarations.
1013	!
1014	integer, intent(in) :: ng, model
1015
1016	character (len=*), intent(inout) :: A(:)
1017	!
1018	! Local variable declarations
1019	!
1020	integer :: Asize, Lstr, MyError, Nchars, Serror
1021
1022	character (len=MPI_MAX_ERROR_STRING) :: string
1023
1024	# ifdef PROFILE
1025	!
1026	!-----------------------------------------------------------------------
1027	! Turn on time clocks.
1028	!-----------------------------------------------------------------------
1029	!
1030	CALL wclock_on (ng, model, 42)
1031	# endif
1032	!
1033	!-----------------------------------------------------------------------
1034	! Broadcast requested variable.
1035	!-----------------------------------------------------------------------
1036	!
1037	Asize=UBOUND(A, DIM=1)
1038	Nchars=LEN(A(1))*Asize
1039
1040	# ifdef MPI
1041	CALL mpi_bcast (A, Nchars, MPI_BYTE, MyMaster, OCN_COMM_WORLD, &
1042	& MyError)
1043	IF (MyError.ne.MPI_SUCCESS) THEN
1044	CALL mpi_error_string (MyError, string, Lstr, Serror)
1045	Lstr=LEN_TRIM(string)
1046	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
1047	10 FORMAT (/,' MP_BCASTS_1D - error during ',a,' call, Node = ', &
1048	& i3.3,' Error = ',i3,/,13x,a)
1049	exit_flag=2
1050	RETURN
1051	END IF
1052	# endif
1053	# ifdef PROFILE
1054	!
1055	!-----------------------------------------------------------------------
1056	! Turn off time clocks.
1057	!-----------------------------------------------------------------------
1058	!
1059	CALL wclock_off (ng, model, 42)
1060	# endif
1061
1062	RETURN
1063	END SUBROUTINE mp_bcasts_1d
1064
1065	SUBROUTINE mp_boundary (ng, model, Imin, Imax, &
1066	& LBi, UBi, LBk, UBk, &
1067	& update, A)
1068	!
1069	!***********************************************************************
1070	! !
1071	! This routine exchanges boundary arrays between tiles. !
1072	! !
1073	! On Input: !
1074	! !
1075	! ng Nested grid number. !
1076	! model Calling model identifier. !
1077	! Imin Starting tile index. !
1078	! Imax Ending tile index. !
1079	! Jstr Starting tile index in the J-direction. !
1080	! Jend Ending tile index in the J-direction. !
1081	! LBi I-dimension Lower bound. !
1082	! UBi I-dimension Upper bound. !
1083	! LBk K-dimension Lower bound, if any. Otherwise, a value !
1084	! of one is expected. !
1085	! LBk K-dimension Upper bound, if any. Otherwise, a value !
1086	! of one is expected. !
1087	! UBk K-dimension Upper bound. !
1088	! update Switch activated by the node that updated the !
1089	! boundary data. !
1090	! A Boundary array (1D or 2D) to process. !
1091	! !
1092	! On Output: !
1093	! !
1094	! A Updated boundary array (1D or 2D). !
1095	! !
1096	!***********************************************************************
1097	!
1098	USE mod_param
1099	USE mod_parallel
1100	USE mod_iounits
1101	USE mod_scalars
1102	!
1103	implicit none
1104	!
1105	! Imported variable declarations.
1106	!
1107	logical, intent(in) :: update
1108
1109	integer, intent(in) :: ng, model, Imin, Imax
1110	integer, intent(in) :: LBi, UBi, LBk, UBk
1111
1112	real(r8), intent(inout) :: A(LBi:UBi,LBk:UBk)
1113	!
1114	! Local variable declarations.
1115	!
1116	integer :: Ilen, Ioff, Lstr, MyError, Nnodes, Npts, Serror
1117	integer :: i, ik, k, kc, rank
1118
1119	real(r8), dimension((UBi-LBi+1)*(UBk-LBk+1)) :: Asend
1120
1121	# ifdef BOUNDARY_ALLREDUCE
1122	real(r8), dimension((UBi-LBi+1)*(UBk-LBk+1)) :: Arecv
1123	# else
1124	real(r8), dimension((UBi-LBi+1)*(UBk-LBk+1), &
1125	& 0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
1126	# endif
1127	character (len=MPI_MAX_ERROR_STRING) :: string
1128
1129	# ifdef PROFILE
1130	!
1131	!-----------------------------------------------------------------------
1132	! Turn on time clocks.
1133	!-----------------------------------------------------------------------
1134	!
1135	CALL wclock_on (ng, model, 46)
1136	# endif
1137	!
1138	!-----------------------------------------------------------------------
1139	! Pack boundary data. Zero-out boundary array except points updated
1140	! by the appropriate node, so sum reduction can be perfomed during
1141	! unpacking.
1142	!-----------------------------------------------------------------------
1143	!
1144	! Initialize buffer to the full range so unpacking is correct with
1145	! summation. This also allows even exchange of segments with
1146	! communication routine "mpi_allgather".
1147	!
1148	Ilen=UBi-LBi+1
1149	Ioff=1-LBi
1150	Npts=Ilen*(UBk-LBk+1)
1151	DO i=1,Npts
1152	Asend(i)=0.0_r8
1153	END DO
1154	!
1155	! If a boundary tile, load boundary data.
1156	!
1157	IF (update) THEN
1158	DO k=LBk,UBk
1159	kc=(k-LBk)*Ilen
1160	DO i=Imin,Imax
1161	ik=i+Ioff+kc
1162	Asend(ik)=A(i,k)
1163	END DO
1164	END DO
1165	END IF
1166	!
1167	!-----------------------------------------------------------------------
1168	! Collect data from all nodes.
1169	!-----------------------------------------------------------------------
1170	!
1171	# ifdef MPI
1172	# ifdef BOUNDARY_ALLREDUCE
1173	CALL mpi_allreduce (Asend, Arecv, Npts, MP_FLOAT, MPI_SUM, &
1174	& OCN_COMM_WORLD, MyError)
1175	IF (MyError.ne.MPI_SUCCESS) THEN
1176	CALL mpi_error_string (MyError, string, Lstr, Serror)
1177	Lstr=LEN_TRIM(string)
1178	WRITE (stdout,10) 'MPI_ALLREDUCE', MyRank, MyError, &
1179	& string(1:Lstr)
1180	10 FORMAT (/,' MP_BOUNDARY - error during ',a,' call, Node = ', &
1181	& i3.3,' Error = ',i3,/,15x,a)
1182	exit_flag=2
1183	RETURN
1184	END IF
1185	# else
1186	CALL mpi_allgather (Asend, Npts, MP_FLOAT, Arecv, Npts, MP_FLOAT, &
1187	& OCN_COMM_WORLD, MyError)
1188	IF (MyError.ne.MPI_SUCCESS) THEN
1189	CALL mpi_error_string (MyError, string, Lstr, Serror)
1190	Lstr=LEN_TRIM(string)
1191	WRITE (stdout,10) 'MPI_ALLGATHER', MyRank, MyError, &
1192	& string(1:Lstr)
1193	10 FORMAT (/,' MP_BOUNDARY - error during ',a,' call, Node = ', &
1194	& i3.3,' Error = ',i3,/,15x,a)
1195	exit_flag=2
1196	RETURN
1197	END IF
1198	# endif
1199	# endif
1200	!
1201	!-----------------------------------------------------------------------
1202	! Unpack data: reduction sum.
1203	!-----------------------------------------------------------------------
1204	!
1205	# ifdef BOUNDARY_ALLREDUCE
1206	ik=0
1207	DO k=LBk,UBk
1208	DO i=LBi,UBi
1209	ik=ik+1
1210	A(i,k)=Arecv(ik)
1211	END DO
1212	END DO
1213	# else
1214	Nnodes=NtileI(ng)*NtileJ(ng)-1
1215	ik=0
1216	DO k=LBk,UBk
1217	DO i=LBi,UBi
1218	A(i,k)=0.0_r8
1219	ik=ik+1
1220	DO rank=0,Nnodes
1221	A(i,k)=A(i,k)+Arecv(ik,rank)
1222	END DO
1223	END DO
1224	END DO
1225	# endif
1226	# ifdef PROFILE
1227	!
1228	!-----------------------------------------------------------------------
1229	! Turn off time clocks.
1230	!-----------------------------------------------------------------------
1231	!
1232	CALL wclock_off (ng, model, 46)
1233	# endif
1234
1235	RETURN
1236	END SUBROUTINE mp_boundary
1237
1238	SUBROUTINE mp_collect (ng, model, Npts, Aspv, A)
1239	!
1240	!***********************************************************************
1241	! !
1242	! This routine collects requested buffer from all members in the !
1243	! group. Then, it packs distributed data by removing the special !
1244	! values. This routine is used when extracting station data from !
1245	! tiled arrays. !
1246	! !
1247	! On Input: !
1248	! !
1249	! ng Nested grid number. !
1250	! model Calling model identifier. !
1251	! Npts Number of extracted data points. !
1252	! Aspv Special value indicating no data. This implies that !
1253	! desired data is tile unbouded. !
1254	! A Extracted data. !
1255	! !
1256	! On Output: !
1257	! !
1258	! A Collected data. !
1259	! !
1260	!***********************************************************************
1261	!
1262	USE mod_param
1263	USE mod_parallel
1264	USE mod_iounits
1265	USE mod_scalars
1266	!
1267	implicit none
1268	!
1269	! Imported variable declarations.
1270	!
1271	integer, intent(in) :: ng, model, Npts
1272
1273	real(r8), intent(in) :: Aspv
1274
1275	real(r8), intent(inout) :: A(Npts)
1276	!
1277	! Local variable declarations.
1278	!
1279	integer :: Lstr, MyError, Nnodes, Serror
1280	integer :: i, rank, request
1281
1282	integer, dimension(MPI_STATUS_SIZE) :: status
1283
1284	# if defined COLLECT_ALLGATHER
1285	real(r8), dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
1286	# elif defined COLLECT_ALLREDUCE
1287	real(r8), dimension(Npts) :: Asend
1288	# else
1289	real(r8), allocatable :: Arecv(:)
1290	# endif
1291
1292	character (len=MPI_MAX_ERROR_STRING) :: string
1293
1294	# ifdef PROFILE
1295	!
1296	!-----------------------------------------------------------------------
1297	! Turn on time clocks.
1298	!-----------------------------------------------------------------------
1299	!
1300	CALL wclock_on (ng, model, 47)
1301	# endif
1302	!
1303	!-----------------------------------------------------------------------
1304	! Collect data from all nodes.
1305	!-----------------------------------------------------------------------
1306	!
1307	# if defined COLLECT_ALLGATHER
1308	CALL mpi_allgather (A, Npts, MP_FLOAT, Arecv, Npts, MP_FLOAT, &
1309	& OCN_COMM_WORLD, MyError)
1310	IF (MyError.ne.MPI_SUCCESS) THEN
1311	CALL mpi_error_string (MyError, string, Lstr, Serror)
1312	Lstr=LEN_TRIM(string)
1313	WRITE (stdout,10) 'MPI_ALLGATHER', MyRank, MyError, &
1314	& string(1:Lstr)
1315	exit_flag=2
1316	RETURN
1317	END IF
1318	!
1319	! Pack data according to special values: sum or ignore.
1320	!
1321	Nnodes=NtileI(ng)*NtileJ(ng)-1
1322	IF (Aspv.eq.0.0_r8) THEN
1323	DO i=1,Npts
1324	A(i)=0.0_r8
1325	DO rank=0,Nnodes
1326	A(i)=A(i)+Arecv(i,rank)
1327	END DO
1328	END DO
1329	ELSE
1330	DO i=1,Npts
1331	DO rank=0,Nnodes
1332	IF (Arecv(i,rank).ne.Aspv) THEN
1333	A(i)=Arecv(i,rank)
1334	END IF
1335	END DO
1336	END DO
1337	END IF
1338	# elif defined COLLECT_ALLREDUCE
1339	!
1340	! Copy data to send.
1341	!
1342	DO i=1,Npts
1343	Asend(i)=A(i)
1344	END DO
1345	!
1346	! Collect data from all nodes as a reduced sum.
1347	!
1348	CALL mpi_allreduce (Asend, A, Npts, MP_FLOAT, MPI_SUM, &
1349	& OCN_COMM_WORLD, MyError)
1350	IF (MyError.ne.MPI_SUCCESS) THEN
1351	CALL mpi_error_string (MyError, string, Lstr, Serror)
1352	Lstr=LEN_TRIM(string)
1353	WRITE (stdout,10) 'MPI_ALLREDUCE', MyRank, MyError, &
1354	& string(1:Lstr)
1355	exit_flag=2
1356	RETURN
1357	END IF
1358	# else
1359	IF (MyRank.eq.MyMaster) THEN
1360	!
1361	! If master node, allocate and receive buffer.
1362	!
1363	IF (.not.allocated(Arecv)) THEN
1364	allocate (Arecv(Npts))
1365	END IF
1366	!
1367	! If master node, loop over other nodes to receive and accumulate the
1368	! data.
1369	!
1370	DO rank=1,NtileI(ng)*NtileJ(ng)-1
1371	CALL mpi_irecv (Arecv, Npts, MP_FLOAT, rank, rank+5, &
1372	& OCN_COMM_WORLD, request, MyError)
1373	CALL mpi_wait (request, status, MyError)
1374	IF (MyError.ne.MPI_SUCCESS) THEN
1375	CALL mpi_error_string (MyError, string, Lstr, Serror)
1376	Lstr=LEN_TRIM(string)
1377	WRITE (stdout,10) 'MPI_IRECV', rank, MyError, string(1:Lstr)
1378	exit_flag=2
1379	RETURN
1380	END IF
1381	DO i=1,Npts
1382	A(i)=A(i)+Arecv(i)
1383	END DO
1384	END DO
1385	deallocate (Arecv)
1386	!
1387	! Otherwise, send data to master node.
1388	!
1389	ELSE
1390	CALL mpi_isend (A, Npts, MP_FLOAT, MyMaster, MyRank+5, &
1391	& OCN_COMM_WORLD, request, MyError)
1392	CALL mpi_wait (request, status, MyError)
1393	IF (MyError.ne.MPI_SUCCESS) THEN
1394	CALL mpi_error_string (MyError, string, Lstr, Serror)
1395	Lstr=LEN_TRIM(string)
1396	WRITE (stdout,10) 'MPI_ISEND', MyRank, MyError, string(1:Lstr)
1397	exit_flag=2
1398	RETURN
1399	END IF
1400	END IF
1401	!
1402	! Broadcast accumulated (full) data to all nodes.
1403	!
1404	CALL mpi_bcast (A, Npts, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
1405	& MyError)
1406	IF (MyError.ne.MPI_SUCCESS) THEN
1407	CALL mpi_error_string (MyError, string, Lstr, Serror)
1408	Lstr=LEN_TRIM(string)
1409	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
1410	exit_flag=2
1411	RETURN
1412	END IF
1413	# endif
1414	10 FORMAT (/,' MP_COLLECT - error during ',a,' call, Node = ', &
1415	& i3.3,' Error = ',i3,/,14x,a)
1416
1417	# ifdef PROFILE
1418	!
1419	!-----------------------------------------------------------------------
1420	! Turn off time clocks.
1421	!-----------------------------------------------------------------------
1422	!
1423	CALL wclock_off (ng, model, 47)
1424	# endif
1425
1426	RETURN
1427	END SUBROUTINE mp_collect
1428
1429	SUBROUTINE mp_gather2d (ng, model, LBi, UBi, LBj, UBj, &
1430	& tindex, gtype, Ascl, &
1431	# ifdef MASKING
1432	& Amask, &
1433	# endif
1434	& A, Npts, Aout, SetFillVal)
1435	!
1436	!***********************************************************************
1437	! !
1438	! This routine collects a 2D tiled, floating-point array from each !
1439	! spawned node and stores it into one dimensional global array. It !
1440	! is used to collect and pack output data. !
1441	! !
1442	! On Input: !
1443	! !
1444	! ng Nested grid number. !
1445	! model Calling model identifier. !
1446	! LBi I-dimension Lower bound. !
1447	! UBi I-dimension Upper bound. !
1448	! LBj J-dimension Lower bound. !
1449	! UBj J-dimension Upper bound. !
1450	! tindex Time record index to process. !
1451	! gtype C-grid type. If negative and Land-Sea is available, !
1452	! only water-points processed. !
1453	! Ascl Factor to scale field before writing. !
1454	! Amask Land/Sea mask, if any. !
1455	! A 2D tiled, floating-point array to process. !
1456	! SetFillVal Logical switch to set fill value in land areas !
1457	! (optional). !
1458	! !
1459	! On Output: !
1460	! !
1461	! Npts Number of points processed in Aout. !
1462	! Aout Collected data from each node packed into 1D array !
1463	! in column-major order. That is, in the same way !
1464	! that Fortran multi-dimensional arrays are stored !
1465	! in memory. !
1466	! !
1467	!***********************************************************************
1468	!
1469	USE mod_param
1470	USE mod_parallel
1471	USE mod_iounits
1472	USE mod_ncparam
1473	USE mod_scalars
1474	!
1475	implicit none
1476	!
1477	! Imported variable declarations.
1478	!
1479	logical, intent(in), optional :: SetFillVal
1480
1481	integer, intent(in) :: ng, model, tindex, gtype
1482	integer, intent(in) :: LBi, UBi, LBj, UBj
1483	integer, intent(out) :: Npts
1484
1485	real(r8), intent(in) :: Ascl
1486
1487	# ifdef MASKING
1488	real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
1489	# endif
1490	real(r8), intent(in) :: A(LBi:UBi,LBj:UBj)
1491	real(r8), intent(out) :: Aout((Lm(ng)+2)*(Mm(ng)+2))
1492	!
1493	! Local variable declarations.
1494	!
1495	# ifdef MASKING
1496	logical :: LandFill
1497	# endif
1498	integer :: Itile, Jtile, Nghost
1499	integer :: Io, Ie, Jo, Je, Ioff, Joff
1500	integer :: Ilen, Jlen
1501	integer :: Lstr, MyError, MyType, Serror, Srequest
1502	integer :: i, ic, j, jc, np, rank
1503
1504	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Imin, Imax
1505	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Jmin, Jmax
1506	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: MySize
1507	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
1508
1509	integer, dimension(MPI_STATUS_SIZE) :: Rstatus
1510	integer, dimension(MPI_STATUS_SIZE) :: Sstatus
1511
1512	real(r8), dimension(TileSize(ng)) :: Asend
1513
1514	real(r8), dimension(TileSize(ng), &
1515	& NtileI(ng)*NtileJ(ng)-1) :: Arecv
1516
1517	character (len=MPI_MAX_ERROR_STRING) :: string
1518
1519	# ifdef PROFILE
1520	!
1521	!-----------------------------------------------------------------------
1522	! Turn on time clocks.
1523	!-----------------------------------------------------------------------
1524	!
1525	CALL wclock_on (ng, model, 44)
1526	# endif
1527	!
1528	!-----------------------------------------------------------------------
1529	! Set horizontal starting and ending indices for parallel domain
1530	! partitions in the XI- and ETA-directions.
1531	!-----------------------------------------------------------------------
1532	!
1533	! Set first and last grid point according to staggered C-grid
1534	! classification.
1535	!
1536	Io=0
1537	Ie=Lm(ng)+1
1538	Jo=0
1539	Je=Mm(ng)+1
1540	MyType=ABS(gtype)
1541	IF ((MyType.eq.p2dvar).or.(MyType.eq.u2dvar).or. &
1542	& (MyType.eq.p3dvar).or.(MyType.eq.u3dvar)) Io=1
1543	IF ((MyType.eq.p2dvar).or.(MyType.eq.v2dvar).or. &
1544	& (MyType.eq.p3dvar).or.(MyType.eq.v3dvar)) Jo=1
1545	IF (Io.eq.0) THEN
1546	Ioff=1
1547	ELSE
1548	Ioff=0
1549	END IF
1550	IF (Jo.eq.0) THEN
1551	Joff=0
1552	ELSE
1553	Joff=1
1554	END IF
1555	Ilen=Ie-Io+1
1556	Jlen=Je-Jo+1
1557	Npts=Ilen*Jlen
1558	!
1559	! Set physical, non-overlaping (no ghost-points) ranges according to
1560	! tile rank. Compute size of distributed buffers.
1561	!
1562	Nghost=0
1563	DO rank=0,NtileI(ng)*NtileJ(ng)-1
1564	CALL get_bounds (ng, rank, gtype, Nghost, Itile, Jtile, &
1565	& Imin(rank), Imax(rank), &
1566	& Jmin(rank), Jmax(rank))
1567	MySize(rank)=(Imax(rank)-Imin(rank)+1)* &
1568	& (Jmax(rank)-Jmin(rank)+1)
1569	END DO
1570	!
1571	! Initialize local arrays to avoid denormalized numbers. This
1572	! facilitates processing and debugging.
1573	!
1574	Asend=0.0_r8
1575	Arecv=0.0_r8
1576	!
1577	!-----------------------------------------------------------------------
1578	! Collect requested array data.
1579	!-----------------------------------------------------------------------
1580	!
1581	! Pack and scale input data.
1582	!
1583	np=0
1584	DO j=Jmin(MyRank),Jmax(MyRank)
1585	DO i=Imin(MyRank),Imax(MyRank)
1586	np=np+1
1587	Asend(np)=A(i,j)*Ascl
1588	END DO
1589	END DO
1590
1591	# ifdef MASKING
1592	!
1593	! If overwriting Land/Sea mask or processing water-points only, flag
1594	! land-points with special value.
1595	!
1596	IF (PRESENT(SetFillVal)) THEN
1597	LandFill=SetFillVal
1598	ELSE
1599	LandFill=tindex.gt.0
1600	END IF
1601	IF (gtype.lt.0) THEN
1602	np=0
1603	DO j=Jmin(MyRank),Jmax(MyRank)
1604	DO i=Imin(MyRank),Imax(MyRank)
1605	np=np+1
1606	IF (Amask(i,j).eq.0.0_r8) THEN
1607	Asend(np)=spval
1608	END IF
1609	END DO
1610	END DO
1611	ELSE IF (LandFill) THEN
1612	np=0
1613	DO j=Jmin(MyRank),Jmax(MyRank)
1614	DO i=Imin(MyRank),Imax(MyRank)
1615	np=np+1
1616	IF (Amask(i,j).eq.0.0_r8) THEN
1617	Asend(np)=spval
1618	END IF
1619	END DO
1620	END DO
1621	END IF
1622	# endif
1623	!
1624	! If master processor, unpack the send buffer since there is not
1625	! need to distribute.
1626	!
1627	IF (MyRank.eq.MyMaster) THEN
1628	np=0
1629	DO j=Jmin(MyRank),Jmax(MyRank)
1630	jc=(j-Joff)*Ilen
1631	DO i=Imin(MyRank),Imax(MyRank)
1632	np=np+1
1633	ic=i+Ioff+jc
1634	Aout(ic)=Asend(np)
1635	END DO
1636	END DO
1637	END IF
1638	!
1639	! Send, receive, and unpack data.
1640	!
1641	IF (MyRank.eq.MyMaster) THEN
1642	DO rank=1,NtileI(ng)*NtileJ(ng)-1
1643	CALL mpi_irecv (Arecv(1,rank), MySize(rank), MP_FLOAT, rank, &
1644	& rank+5, OCN_COMM_WORLD, Rrequest(rank), &
1645	& MyError)
1646	END DO
1647	DO rank=1,NtileI(ng)*NtileJ(ng)-1
1648	CALL mpi_wait (Rrequest(rank), Rstatus, MyError)
1649	IF (MyError.ne.MPI_SUCCESS) THEN
1650	CALL mpi_error_string (MyError, string, Lstr, Serror)
1651	Lstr=LEN_TRIM(string)
1652	WRITE (stdout,10) 'MPI_IRECV', rank, MyError, string(1:Lstr)
1653	10 FORMAT (/,' MP_GATHER2D - error during ',a,' call, Node = ',&
1654	& i3.3,' Error = ',i3,/,13x,a)
1655	exit_flag=2
1656	RETURN
1657	END IF
1658	np=0
1659	DO j=Jmin(rank),Jmax(rank)
1660	jc=(j-Joff)*Ilen
1661	DO i=Imin(rank),Imax(rank)
1662	np=np+1
1663	ic=i+Ioff+jc
1664	Aout(ic)=Arecv(np,rank)
1665	END DO
1666	END DO
1667	END DO
1668	ELSE
1669	CALL mpi_isend (Asend, MySize(MyRank), MP_FLOAT, MyMaster, &
1670	& MyRank+5, OCN_COMM_WORLD, Srequest, MyError)
1671	CALL mpi_wait (Srequest, Sstatus, MyError)
1672	IF (MyError.ne.MPI_SUCCESS) THEN
1673	CALL mpi_error_string (MyError, string, Lstr, Serror)
1674	Lstr=LEN_TRIM(string)
1675	WRITE (stdout,10) 'MPI_ISEND', MyRank, MyError, string(1:Lstr)
1676	exit_flag=2
1677	RETURN
1678	END IF
1679	END IF
1680
1681	# ifdef MASKING
1682	!
1683	! If pocessing only water-points, remove land points and repack.
1684	!
1685	IF ((MyRank.eq.MyMaster).and.(gtype.lt.0)) THEN
1686	ic=0
1687	np=Ilen*Jlen
1688	DO i=1,np
1689	IF (Aout(i).lt.spval) THEN
1690	ic=ic+1
1691	Aout(ic)=Aout(i)
1692	END IF
1693	END DO
1694	Npts=ic
1695	END IF
1696	# endif
1697	# ifdef PROFILE
1698	!
1699	!-----------------------------------------------------------------------
1700	! Turn off time clocks.
1701	!-----------------------------------------------------------------------
1702	!
1703	CALL wclock_off (ng, model, 44)
1704	# endif
1705
1706	RETURN
1707	END SUBROUTINE mp_gather2d
1708
1709	SUBROUTINE mp_gather3d (ng, model, LBi, UBi, LBj, UBj, LBk, UBk, &
1710	& tindex, gtype, Ascl, &
1711	# ifdef MASKING
1712	& Amask, &
1713	# endif
1714	& A, Npts, Aout, SetFillVal)
1715	!
1716	!***********************************************************************
1717	! !
1718	! This routine collects a 3D tiled, floating-point array from each !
1719	! spawned node and stores it into one dimensional global array. It !
1720	! is used to collect and pack output data. !
1721	! !
1722	! On Input: !
1723	! !
1724	! ng Nested grid number. !
1725	! model Calling model identifier. !
1726	! LBi I-dimension Lower bound. !
1727	! UBi I-dimension Upper bound. !
1728	! LBj J-dimension Lower bound. !
1729	! UBj J-dimension Upper bound. !
1730	! LBk K-dimension Lower bound. !
1731	! UBk K-dimension Upper bound. !
1732	! tindex Time record index to process. !
1733	! gtype C-grid type. If negative and Land-Sea is available, !
1734	! only water-points processed. !
1735	! Ascl Factor to scale field before writing. !
1736	! Amask Land/Sea mask, if any. !
1737	! A 3D tiled, floating-point array to process. !
1738	! SetFillVal Logical switch to set fill value in land areas !
1739	! (optional). !
1740	! !
1741	! On Output: !
1742	! !
1743	! Npts Number of points processed in Aout. !
1744	! Aout Collected data from each node packed into 1D array !
1745	! in column-major order. That is, in the same way !
1746	! that Fortran multi-dimensional arrays are stored !
1747	! in memory. !
1748	! !
1749	!***********************************************************************
1750	!
1751	USE mod_param
1752	USE mod_parallel
1753	USE mod_iounits
1754	USE mod_ncparam
1755	USE mod_scalars
1756	!
1757	implicit none
1758	!
1759	! Imported variable declarations.
1760	!
1761	logical, intent(in), optional :: SetFillVal
1762
1763	integer, intent(in) :: ng, model, tindex, gtype
1764	integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
1765	integer, intent(out) :: Npts
1766
1767	real(r8), intent(in) :: Ascl
1768
1769	# ifdef MASKING
1770	real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
1771	# endif
1772	real(r8), intent(in) :: A(LBi:UBi,LBj:UBj,LBk:UBk)
1773	real(r8), intent(out) :: Aout((Lm(ng)+2)(Mm(ng)+2)(UBk-LBk+1))
1774	!
1775	! Local variable declarations.
1776	!
1777	# ifdef MASKING
1778	logical :: LandFill
1779	# endif
1780	integer :: Itile, Jtile, Nghost
1781	integer :: Io, Ie, Jo, Je, Ioff, Joff, Koff
1782	integer :: Ilen, Jlen, Klen, IJlen
1783	integer :: Lstr, MyError, MyType, Serror, Srequest
1784	integer :: i, ic, j, jc, k, kc, np, rank
1785
1786	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Imin, Imax
1787	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Jmin, Jmax
1788	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: MySize
1789	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
1790
1791	integer, dimension(MPI_STATUS_SIZE) :: Rstatus
1792	integer, dimension(MPI_STATUS_SIZE) :: Sstatus
1793
1794	real(r8), dimension(TileSize(ng)*(UBk-LBk+1)) :: Asend
1795
1796	real(r8), dimension(TileSize(ng)*(UBk-LBk+1), &
1797	& NtileI(ng)*NtileJ(ng)-1) :: Arecv
1798
1799	character (len=MPI_MAX_ERROR_STRING) :: string
1800
1801	# ifdef PROFILE
1802	!
1803	!-----------------------------------------------------------------------
1804	! Turn on time clocks.
1805	!-----------------------------------------------------------------------
1806	!
1807	CALL wclock_on (ng, model, 44)
1808	# endif
1809	!
1810	!-----------------------------------------------------------------------
1811	! Set horizontal starting and ending indices for parallel domain
1812	! partitions in the XI- and ETA-directions.
1813	!-----------------------------------------------------------------------
1814	!
1815	! Set first and last grid point according to staggered C-grid
1816	! classification.
1817	!
1818	Io=0
1819	Ie=Lm(ng)+1
1820	Jo=0
1821	Je=Mm(ng)+1
1822	MyType=ABS(gtype)
1823	IF ((MyType.eq.p3dvar).or.(MyType.eq.u3dvar)) Io=1
1824	IF ((MyType.eq.p3dvar).or.(MyType.eq.v3dvar)) Jo=1
1825	IF (Io.eq.0) THEN
1826	Ioff=1
1827	ELSE
1828	Ioff=0
1829	END IF
1830	IF (Jo.eq.0) THEN
1831	Joff=0
1832	ELSE
1833	Joff=1
1834	END IF
1835	IF (LBk.eq.0) THEN
1836	Koff=0
1837	ELSE
1838	Koff=1
1839	END IF
1840	Ilen=Ie-Io+1
1841	Jlen=Je-Jo+1
1842	Klen=UBk-LBk+1
1843	IJlen=Ilen*Jlen
1844	Npts=IJlen*Klen
1845	!
1846	! Set physical, non-overlaping (no ghost-points) ranges according to
1847	! tile rank. Compute size of distributed buffers.
1848	!
1849	Nghost=0
1850	DO rank=0,NtileI(ng)*NtileJ(ng)-1
1851	CALL get_bounds (ng, rank, gtype, Nghost, Itile, Jtile, &
1852	& Imin(rank), Imax(rank), &
1853	& Jmin(rank), Jmax(rank))
1854	MySize(rank)=(Imax(rank)-Imin(rank)+1)* &
1855	& (Jmax(rank)-Jmin(rank)+1)*(UBk-LBk+1)
1856	END DO
1857	!
1858	! Initialize local arrays to avoid denormalized numbers. This
1859	! facilitates processing and debugging.
1860	!
1861	Asend=0.0_r8
1862	Arecv=0.0_r8
1863	!
1864	!-----------------------------------------------------------------------
1865	! Collect requested array data.
1866	!-----------------------------------------------------------------------
1867	!
1868	! Pack and scale input data.
1869	!
1870	np=0
1871	DO k=LBk,UBk
1872	DO j=Jmin(MyRank),Jmax(MyRank)
1873	DO i=Imin(MyRank),Imax(MyRank)
1874	np=np+1
1875	Asend(np)=A(i,j,k)*Ascl
1876	END DO
1877	END DO
1878	END DO
1879
1880	# ifdef MASKING
1881	!
1882	! If overwriting Land/Sea mask or processing water-points only, flag
1883	! land-points with special value.
1884	!
1885	IF (PRESENT(SetFillVal)) THEN
1886	LandFill=SetFillVal
1887	ELSE
1888	LandFill=tindex.gt.0
1889	END IF
1890	IF (gtype.lt.0) THEN
1891	np=0
1892	DO k=LBk,UBk
1893	DO j=Jmin(MyRank),Jmax(MyRank)
1894	DO i=Imin(MyRank),Imax(MyRank)
1895	np=np+1
1896	IF (Amask(i,j).eq.0.0_r8) THEN
1897	Asend(np)=spval
1898	END IF
1899	END DO
1900	END DO
1901	END DO
1902	ELSE IF (LandFill) THEN
1903	np=0
1904	DO k=LBk,UBk
1905	DO j=Jmin(MyRank),Jmax(MyRank)
1906	DO i=Imin(MyRank),Imax(MyRank)
1907	np=np+1
1908	IF (Amask(i,j).eq.0.0_r8) THEN
1909	Asend(np)=spval
1910	END IF
1911	END DO
1912	END DO
1913	END DO
1914	END IF
1915	# endif
1916	!
1917	! If master processor, unpack the send buffer since there is not
1918	! need to distribute.
1919	!
1920	IF (MyRank.eq.MyMaster) THEN
1921	np=0
1922	DO k=LBk,UBk
1923	kc=(k-Koff)*IJlen
1924	DO j=Jmin(MyRank),Jmax(MyRank)
1925	jc=(j-Joff)*Ilen+kc
1926	DO i=Imin(MyRank),Imax(MyRank)
1927	np=np+1
1928	ic=i+Ioff+jc
1929	Aout(ic)=Asend(np)
1930	END DO
1931	END DO
1932	END DO
1933	END IF
1934	!
1935	! Send, receive, and unpack data.
1936	!
1937	IF (MyRank.eq.MyMaster) THEN
1938	DO rank=1,NtileI(ng)*NtileJ(ng)-1
1939	CALL mpi_irecv (Arecv(1,rank), MySize(rank), MP_FLOAT, rank, &
1940	& rank+5, OCN_COMM_WORLD, Rrequest(rank), &
1941	& MyError)
1942	END DO
1943	DO rank=1,NtileI(ng)*NtileJ(ng)-1
1944	CALL mpi_wait (Rrequest(rank), Rstatus, MyError)
1945	IF (MyError.ne.MPI_SUCCESS) THEN
1946	CALL mpi_error_string (MyError, string, Lstr, Serror)
1947	Lstr=LEN_TRIM(string)
1948	WRITE (stdout,10) 'MPI_IRECV', rank, MyError, string(1:Lstr)
1949	10 FORMAT (/,' MP_GATHER3D - error during ',a,' call, Node = ',&
1950	& i3.3,' Error = ',i3,/,13x,a)
1951	exit_flag=2
1952	RETURN
1953	END IF
1954	np=0
1955	DO k=LBk,UBk
1956	kc=(k-Koff)*IJlen
1957	DO j=Jmin(rank),Jmax(rank)
1958	jc=(j-Joff)*Ilen+kc
1959	DO i=Imin(rank),Imax(rank)
1960	np=np+1
1961	ic=i+Ioff+jc
1962	Aout(ic)=Arecv(np,rank)
1963	END DO
1964	END DO
1965	END DO
1966	END DO
1967	ELSE
1968	CALL mpi_isend (Asend, MySize(MyRank), MP_FLOAT, MyMaster, &
1969	& MyRank+5, OCN_COMM_WORLD, Srequest, MyError)
1970	CALL mpi_wait (Srequest, Sstatus, MyError)
1971	IF (MyError.ne.MPI_SUCCESS) THEN
1972	CALL mpi_error_string (MyError, string, Lstr, Serror)
1973	Lstr=LEN_TRIM(string)
1974	WRITE (stdout,10) 'MPI_ISEND', MyRank, MyError, string(1:Lstr)
1975	exit_flag=2
1976	RETURN
1977	END IF
1978	END IF
1979
1980	# ifdef MASKING
1981	!
1982	! If pocessing only water-points, remove land points and repack.
1983	!
1984	IF ((MyRank.eq.MyMaster).and.(gtype.lt.0)) THEN
1985	ic=0
1986	np=IJlen*Klen
1987	DO i=1,np
1988	IF (Aout(i).lt.spval) THEN
1989	ic=ic+1
1990	Aout(ic)=Aout(i)
1991	END IF
1992	END DO
1993	Npts=ic
1994	END IF
1995	# endif
1996	# ifdef PROFILE
1997	!
1998	!-----------------------------------------------------------------------
1999	! Turn off time clocks.
2000	!-----------------------------------------------------------------------
2001	!
2002	CALL wclock_off (ng, model, 44)
2003	# endif
2004
2005	RETURN
2006	END SUBROUTINE mp_gather3d
2007
2008	SUBROUTINE mp_gather_state (ng, model, Nstr, Nend, Asize, &
2009	& A, Aout)
2010	!
2011	!***********************************************************************
2012	! !
2013	! This routine gathers (threaded to global) state data to all nodes !
2014	! in the group. This routine is used to unpack the state data for !
2015	! the GST analysis propagators. !
2016	! !
2017	! On Input: !
2018	! !
2019	! ng Nested grid number. !
2020	! model Calling model identifier. !
2021	! Nstr Threaded array lower bound. !
2022	! Nend Threaded array upper bound. !
2023	! Asize Size of the full state. !
2024	! A Threaded 1D array process. !
2025	! !
2026	! On Output: !
2027	! !
2028	! Aout Collected data from each node packed into 1D full !
2029	! state array. !
2030	! !
2031	!***********************************************************************
2032	!
2033	USE mod_param
2034	USE mod_parallel
2035	USE mod_iounits
2036	USE mod_ncparam
2037	USE mod_scalars
2038	!
2039	implicit none
2040	!
2041	! Imported variable declarations.
2042	!
2043	integer, intent(in) :: ng, model
2044	integer, intent(in) :: Nstr, Nend, Asize
2045
2046	real(r8), intent(in) :: A(Nstr:Nend)
2047	real(r8), intent(out) :: Aout(Asize)
2048	!
2049	! Local variable declarations.
2050	!
2051	integer :: LB, Lstr, MyError, Serror
2052	integer :: i, np, rank, request
2053
2054	integer :: my_bounds(2)
2055	integer, dimension(MPI_STATUS_SIZE) :: status
2056	integer, dimension(2,0:NtileI(ng)*NtileJ(ng)-1) :: Abounds
2057
2058	character (len=MPI_MAX_ERROR_STRING) :: string
2059
2060	# ifdef PROFILE
2061	!
2062	!-----------------------------------------------------------------------
2063	! Turn on time clocks.
2064	!-----------------------------------------------------------------------
2065	!
2066	CALL wclock_on (ng, model, 44)
2067	# endif
2068	!
2069	!-----------------------------------------------------------------------
2070	! Collect data from all nodes.
2071	!-----------------------------------------------------------------------
2072	!
2073	! Collect data lower and upper bound dimensions.
2074	!
2075	my_bounds(1)=Nstr
2076	my_bounds(2)=Nend
2077	CALL mpi_allgather (my_bounds, 2, MPI_INTEGER, Abounds, 2, &
2078	& MPI_INTEGER, OCN_COMM_WORLD, MyError)
2079	IF (MyError.ne.MPI_SUCCESS) THEN
2080	CALL mpi_error_string (MyError, string, Lstr, Serror)
2081	Lstr=LEN_TRIM(string)
2082	WRITE (stdout,10) 'MPI_ALLGATHER', MyRank, MyError, &
2083	& string(1:Lstr)
2084	10 FORMAT (/,' MP_GATHER_STATE - error during ',a, &
2085	& ' call, Node = ',i3.3,' Error = ',i3,/,13x,a)
2086	exit_flag=2
2087	RETURN
2088	END IF
2089	!
2090	! If master node, loop over other nodes and receive the data.
2091	!
2092	IF (MyRank.eq.MyMaster) THEN
2093	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2094	np=Abounds(2,rank)-Abounds(1,rank)+1
2095	LB=Abounds(1,rank)
2096	CALL mpi_irecv (Aout(LB:), np, MP_FLOAT, rank, rank+5, &
2097	& OCN_COMM_WORLD, request, MyError)
2098	CALL mpi_wait (request, status, MyError)
2099	IF (MyError.ne.MPI_SUCCESS) THEN
2100	CALL mpi_error_string (MyError, string, Lstr, Serror)
2101	Lstr=LEN_TRIM(string)
2102	WRITE (stdout,10) 'MPI_IRECV', rank, MyError, string(1:Lstr)
2103	exit_flag=2
2104	RETURN
2105	END IF
2106	END DO
2107	!
2108	! Load master node contribution.
2109	!
2110	DO i=Nstr,Nend
2111	Aout(i)=A(i)
2112	END DO
2113	!
2114	! Otherwise, send data to master node.
2115	!
2116	ELSE
2117	np=Nend-Nstr+1
2118	CALL mpi_isend (A(Nstr:), np, MP_FLOAT, MyMaster, MyRank+5, &
2119	& OCN_COMM_WORLD, request, MyError)
2120	CALL mpi_wait (request, status, MyError)
2121	IF (MyError.ne.MPI_SUCCESS) THEN
2122	CALL mpi_error_string (MyError, string, Lstr, Serror)
2123	Lstr=LEN_TRIM(string)
2124	WRITE (stdout,10) 'MPI_ISEND', MyRank, MyError, string(1:Lstr)
2125	exit_flag=2
2126	RETURN
2127	END IF
2128	END IF
2129	!
2130	! Broadcast collected data to all nodes.
2131	!
2132	CALL mpi_bcast (Aout, Asize, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
2133	& MyError)
2134	IF (MyError.ne.MPI_SUCCESS) THEN
2135	CALL mpi_error_string (MyError, string, Lstr, Serror)
2136	Lstr=LEN_TRIM(string)
2137	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
2138	exit_flag=2
2139	RETURN
2140	END IF
2141
2142	# ifdef PROFILE
2143	!
2144	!-----------------------------------------------------------------------
2145	! Turn off time clocks.
2146	!-----------------------------------------------------------------------
2147	!
2148	CALL wclock_off (ng, model, 44)
2149	# endif
2150
2151	RETURN
2152	END SUBROUTINE mp_gather_state
2153
2154	FUNCTION mp_ncread (ng, model, ncid, ncvname, ncname, ncrec, &
2155	& LB1, UB1, LB2, UB2, Ascale, A)
2156	!
2157	!***********************************************************************
2158	! !
2159	! This function reads floating point data from specified NetCDF file !
2160	! and scatters it to the other nodes. This routine is used to read !
2161	! model state vectors or matrices. If both LB2 and UB2 are zero, its !
2162	! assumed that the second dimension is a parallel node dimension. !
2163	! !
2164	! On Input: !
2165	! !
2166	! ng Nested grid number. !
2167	! model Calling model identifier. !
2168	! ncid NetCDF file ID. !
2169	! ncvname NetCDF variable name. !
2170	! ncname NetCDF file name. !
2171	! ncrec NetCDF record index to write. If negative, it assumes !
2172	! that the variable is recordless. !
2173	! LB1 First-dimension Lower bound. !
2174	! UB1 First-dimension Upper bound. !
2175	! LB2 Second-dimension Lower bound. !
2176	! UB2 Second-dimension Upper bound. !
2177	! Ascale Factor to scale field after reading (real). !
2178	! !
2179	! On Output: !
2180	! !
2181	! A Field to read in (real). !
2182	! mp_ncread Error flag (integer). !
2183	! !
2184	! Note: We cannot use mod_netcdf here because of cyclic dependency. !
2185	! !
2186	!***********************************************************************
2187	!
2188	USE mod_param
2189	USE mod_parallel
2190	USE mod_iounits
2191	USE mod_ncparam
2192	USE netcdf
2193	USE mod_scalars
2194	!
2195	implicit none
2196	!
2197	! Imported variable declarations.
2198	!
2199	integer, intent(in) :: ng, model, ncid, ncrec
2200	integer, intent(in) :: LB1, UB1, LB2, UB2
2201
2202	real(r8), intent(in) :: Ascale
2203
2204	real(r8), intent(out) :: A(LB1:UB1,LB2:UB2)
2205
2206	character (len=*), intent(in) :: ncvname
2207	character (len=*), intent(in) :: ncname
2208	!
2209	! Local variable declarations.
2210	!
2211	logical :: IsNodeDim
2212
2213	integer :: Lstr, MyError, Npts, Serror
2214	integer :: i, j, np, rank, request, varid
2215	integer :: ibuffer(2), my_bounds(4), start(2), total(2)
2216
2217	integer, dimension(MPI_STATUS_SIZE) :: status
2218	integer, dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: Asize
2219
2220	integer :: mp_ncread
2221
2222	real(r8), allocatable :: Asend(:)
2223
2224	character (len=MPI_MAX_ERROR_STRING) :: string
2225
2226	# ifdef PROFILE
2227	!
2228	!-----------------------------------------------------------------------
2229	! Turn on time clocks.
2230	!-----------------------------------------------------------------------
2231	!
2232	CALL wclock_on (ng, model, 45)
2233	# endif
2234	!
2235	!-----------------------------------------------------------------------
2236	! Read requested NetCDF file and scatter it to all nodes.
2237	!-----------------------------------------------------------------------
2238	!
2239	mp_ncread=nf90_noerr
2240	IF ((LB2.eq.0).and.(UB2.eq.0)) THEN
2241	IsNodeDim=.TRUE.
2242	ELSE
2243	IsNodeDim=.FALSE.
2244	END IF
2245	!
2246	! Collect data lower and upper bounds dimensions.
2247	!
2248	my_bounds(1)=LB1
2249	my_bounds(2)=UB1
2250	my_bounds(3)=LB2
2251	my_bounds(4)=UB2
2252	CALL mpi_gather (my_bounds, 4, MPI_INTEGER, Asize, 4, &
2253	& MPI_INTEGER, MyMaster, OCN_COMM_WORLD, MyError)
2254	IF (MyError.ne.MPI_SUCCESS) THEN
2255	CALL mpi_error_string (MyError, string, Lstr, Serror)
2256	Lstr=LEN_TRIM(string)
2257	WRITE (stdout,10) 'MPI_GATHER', MyRank, MyError, &
2258	& string(1:Lstr)
2259	exit_flag=2
2260	RETURN
2261	END IF
2262	!
2263	! If not master node, receive data from master node.
2264	!
2265	IF (MyRank.ne.MyMaster) THEN
2266	np=(UB1-LB1+1)*(UB2-LB2+1)
2267	CALL mpi_irecv (A(LB1,LB2), np, MP_FLOAT, MyMaster, MyRank+5, &
2268	& OCN_COMM_WORLD, request, MyError)
2269	CALL mpi_wait (request, status, MyError)
2270	IF (MyError.ne.MPI_SUCCESS) THEN
2271	CALL mpi_error_string (MyError, string, Lstr, Serror)
2272	Lstr=LEN_TRIM(string)
2273	WRITE (stdout,10) 'MPI_IRECV', MyRank, MyError, string(1:Lstr)
2274	exit_flag=2
2275	RETURN
2276	END IF
2277	!
2278	! Scale recieved (read) data.
2279	!
2280	DO j=LB2,UB2
2281	DO i=LB1,UB1
2282	A(i,j)=A(i,j)*Ascale
2283	END DO
2284	END DO
2285	!
2286	! Otherwise, if master node allocate the send buffer.
2287	!
2288	ELSE
2289	Npts=0
2290	DO rank=0,NtileI(ng)*NtileJ(ng)-1
2291	np=(Asize(2,rank)-Asize(1,rank)+1)* &
2292	& (Asize(4,rank)-Asize(3,rank)+1)
2293	Npts=MAX(Npts, np)
2294	END DO
2295	IF (.not.allocated(Asend)) THEN
2296	allocate (Asend(Npts))
2297	END IF
2298	!
2299	! If master node, loop over all nodes and read buffers to send.
2300	!
2301	mp_ncread=nf90_inq_varid(ncid, TRIM(ncvname), varid)
2302	IF (mp_ncread.ne.nf90_noerr) THEN
2303	WRITE (stdout,20) TRIM(ncvname), TRIM(ncname)
2304	exit_flag=2
2305	ioerror=mp_ncread
2306	END IF
2307	IF (exit_flag.eq.NoError) THEN
2308	DO rank=0,NtileI(ng)*NtileJ(ng)-1
2309	start(1)=Asize(1,rank)
2310	total(1)=Asize(2,rank)-Asize(1,rank)+1
2311	IF (IsNodeDim) THEN
2312	start(2)=rank+1
2313	total(2)=1
2314	ELSE
2315	start(2)=Asize(3,rank)
2316	total(2)=Asize(4,rank)-Asize(3,rank)+1
2317	END IF
2318	mp_ncread=nf90_get_var(ncid, varid, Asend, start, total)
2319	IF (mp_ncread.ne.nf90_noerr) THEN
2320	WRITE (stdout,30) TRIM(ncvname), TRIM(ncname)
2321	exit_flag=2
2322	ioerror=mp_ncread
2323	EXIT
2324	END IF
2325	!
2326	! Send buffer to all nodes, except itself.
2327	!
2328	IF (rank.eq.MyMaster) THEN
2329	np=0
2330	DO j=LB2,UB2
2331	DO i=LB1,UB1
2332	np=np+1
2333	A(i,j)=Asend(np)*Ascale
2334	END DO
2335	END DO
2336	ELSE
2337	np=(Asize(2,rank)-Asize(1,rank)+1)* &
2338	& (Asize(4,rank)-Asize(3,rank)+1)
2339	CALL mpi_isend (Asend, np, MP_FLOAT, rank, rank+5, &
2340	& OCN_COMM_WORLD, request, MyError)
2341	CALL mpi_wait (request, status, MyError)
2342	IF (MyError.ne.MPI_SUCCESS) THEN
2343	CALL mpi_error_string (MyError, string, Lstr, Serror)
2344	Lstr=LEN_TRIM(string)
2345	WRITE (stdout,10) 'MPI_ISEND', rank, MyError, &
2346	& string(1:Lstr)
2347	exit_flag=2
2348	RETURN
2349	END IF
2350	END IF
2351	END DO
2352	END IF
2353	END IF
2354	!
2355	! Broadcast error flags to all nodes.
2356	!
2357	ibuffer(1)=exit_flag
2358	ibuffer(2)=ioerror
2359	CALL mp_bcasti (ng, model, ibuffer)
2360	exit_flag=ibuffer(1)
2361	ioerror=ibuffer(2)
2362	!
2363	! Deallocate send buffer.
2364	!
2365	IF (allocated(Asend).and.(MyRank.eq.MyMaster)) THEN
2366	deallocate (Asend)
2367	END IF
2368
2369	# ifdef PROFILE
2370	!
2371	!-----------------------------------------------------------------------
2372	! Turn on time clocks.
2373	!-----------------------------------------------------------------------
2374	!
2375	CALL wclock_off (ng, model, 45)
2376	# endif
2377
2378	10 FORMAT (/,' MP_NCREAD - error during ',a,' call, Node = ', &
2379	& i3.3,' Error = ',i3,/,13x,a)
2380	20 FORMAT (/,' MP_NCREAD - error while inquiring ID for variable: ', &
2381	& a,/,13x,'in file: ',a)
2382	30 FORMAT (/,' MP_NCREAD - error while reading variable: ', &
2383	& a,/,13x,'in file: ',a)
2384
2385	RETURN
2386	END FUNCTION mp_ncread
2387
2388	FUNCTION mp_ncwrite (ng, model, ncid, ncvname, ncname, ncrec, &
2389	& LB1, UB1, LB2, UB2, Ascale, A)
2390	!
2391	!***********************************************************************
2392	! !
2393	! This function collects floating point data from the other nodes and !
2394	! writes it into specified NetCDF file. This routine is used to write !
2395	! model state vectors or matrices. It boths LB2 and UB2 are zero, its !
2396	! assumed that the second dimension is a parallel node dimension. !
2397	! !
2398	! On Input: !
2399	! !
2400	! ng Nested grid number. !
2401	! model Calling model identifier. !
2402	! ncid NetCDF file ID. !
2403	! ncvname NetCDF variable name. !
2404	! ncname NetCDF file name. !
2405	! ncrec NetCDF record index to write. If negative, it assumes !
2406	! that the variable is recordless. !
2407	! LB1 First-dimension Lower bound. !
2408	! UB1 First-dimension Upper bound. !
2409	! LB2 Second-dimension Lower bound. !
2410	! UB2 Second-dimension Upper bound. !
2411	! Ascale Factor to scale field before writing (real). !
2412	! A Field to write out (real). !
2413	! !
2414	! On Output: !
2415	! !
2416	! mp_ncwrite Error flag (integer). !
2417	! !
2418	! Note: We cannot use mod_netcdf here because of cyclic dependency. !
2419	! !
2420	!***********************************************************************
2421	!
2422	USE mod_param
2423	USE mod_parallel
2424	USE mod_iounits
2425	USE mod_ncparam
2426	USE netcdf
2427	USE mod_scalars
2428	!
2429	implicit none
2430	!
2431	! Imported variable declarations.
2432	!
2433	integer, intent(in) :: ng, model, ncid, ncrec
2434	integer, intent(in) :: LB1, UB1, LB2, UB2
2435
2436	real(r8), intent(in) :: Ascale
2437
2438	real(r8), intent(in) :: A(LB1:UB1,LB2:UB2)
2439
2440	character (len=*), intent(in) :: ncvname
2441	character (len=*), intent(in) :: ncname
2442	!
2443	! Local variable declarations.
2444	!
2445	logical :: IsNodeDim
2446
2447	integer :: Lstr, MyError, Npts, Serror
2448	integer :: i, j, np, rank, request, varid
2449	integer :: ibuffer(2), my_bounds(4), start(2), total(2)
2450
2451	integer, dimension(MPI_STATUS_SIZE) :: status
2452	integer, dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: Asize
2453
2454	integer :: mp_ncwrite
2455
2456	real(r8), allocatable :: Arecv(:)
2457
2458	character (len=MPI_MAX_ERROR_STRING) :: string
2459
2460	# ifdef PROFILE
2461	!
2462	!-----------------------------------------------------------------------
2463	! Turn on time clocks.
2464	!-----------------------------------------------------------------------
2465	!
2466	CALL wclock_on (ng, model, 44)
2467	# endif
2468	!
2469	!-----------------------------------------------------------------------
2470	! Collect and write data into requested NetCDF file.
2471	!-----------------------------------------------------------------------
2472	!
2473	mp_ncwrite=nf90_noerr
2474	IF ((LB2.eq.0).and.(UB2.eq.0)) THEN
2475	IsNodeDim=.TRUE.
2476	ELSE
2477	IsNodeDim=.FALSE.
2478	END IF
2479	!
2480	! Collect data lower and upper bounds dimensions.
2481	!
2482	my_bounds(1)=LB1
2483	my_bounds(2)=UB1
2484	my_bounds(3)=LB2
2485	my_bounds(4)=UB2
2486	CALL mpi_gather (my_bounds, 4, MPI_INTEGER, Asize, 4, &
2487	& MPI_INTEGER, MyMaster, OCN_COMM_WORLD, MyError)
2488	IF (MyError.ne.MPI_SUCCESS) THEN
2489	CALL mpi_error_string (MyError, string, Lstr, Serror)
2490	Lstr=LEN_TRIM(string)
2491	WRITE (stdout,10) 'MPI_GATHER', MyRank, MyError, &
2492	& string(1:Lstr)
2493	exit_flag=2
2494	RETURN
2495	END IF
2496	!
2497	! If master node, allocate the receive buffer.
2498	!
2499	IF (MyRank.eq.MyMaster) THEN
2500	Npts=0
2501	DO rank=0,NtileI(ng)*NtileJ(ng)-1
2502	np=(Asize(2,rank)-Asize(1,rank)+1)* &
2503	& (Asize(4,rank)-Asize(3,rank)+1)
2504	Npts=MAX(Npts, np)
2505	END DO
2506	IF (.not.allocated(Arecv)) THEN
2507	allocate (Arecv(Npts))
2508	END IF
2509	!
2510	! Write out master node contribution.
2511	!
2512	start(1)=LB1
2513	total(1)=UB1-LB1+1
2514	IF (IsNodeDim) THEN
2515	start(2)=MyRank+1
2516	total(2)=1
2517	ELSE
2518	start(2)=LB2
2519	total(2)=UB2-LB2+1
2520	END IF
2521	np=0
2522	DO j=LB2,UB2
2523	DO i=LB1,UB1
2524	np=np+1
2525	Arecv(np)=A(i,j)
2526	END DO
2527	END DO
2528	mp_ncwrite=nf90_inq_varid(ncid, TRIM(ncvname), varid)
2529	IF (mp_ncwrite.eq.nf90_noerr) THEN
2530	mp_ncwrite=nf90_put_var(ncid, varid, Arecv, start, total)
2531	IF (mp_ncwrite.ne.nf90_noerr) THEN
2532	WRITE (stdout,20) TRIM(ncvname), TRIM(ncname)
2533	exit_flag=3
2534	ioerror=mp_ncwrite
2535	END IF
2536	ELSE
2537	WRITE (stdout,30) TRIM(ncvname), TRIM(ncname)
2538	exit_flag=3
2539	ioerror=mp_ncwrite
2540	END IF
2541	!
2542	! If master node, loop over other nodes and receive the data.
2543	!
2544	IF (exit_flag.ne.NoError) THEN
2545	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2546	np=(Asize(2,rank)-Asize(1,rank)+1)* &
2547	& (Asize(4,rank)-Asize(3,rank)+1)
2548	CALL mpi_irecv (Arecv, np, MP_FLOAT, rank, rank+5, &
2549	& OCN_COMM_WORLD, request, MyError)
2550	CALL mpi_wait (request, status, MyError)
2551	IF (MyError.ne.MPI_SUCCESS) THEN
2552	CALL mpi_error_string (MyError, string, Lstr, Serror)
2553	Lstr=LEN_TRIM(string)
2554	WRITE (stdout,10) 'MPI_IRECV', rank, MyError, &
2555	& string(1:Lstr)
2556	exit_flag=3
2557	RETURN
2558	END IF
2559	!
2560	! Write out data into NetCDF file.
2561	!
2562	start(1)=Asize(1,rank)
2563	total(1)=Asize(2,rank)-Asize(1,rank)+1
2564	IF (IsNodeDim) THEN
2565	start(2)=rank+1
2566	total(2)=1
2567	ELSE
2568	start(2)=Asize(3,rank)
2569	total(2)=Asize(4,rank)-Asize(3,rank)+1
2570	END IF
2571	DO i=1,np
2572	Arecv(i)=Arecv(i)*Ascale
2573	END DO
2574	mp_ncwrite=nf90_put_var(ncid, varid, Arecv, start, total)
2575	IF (mp_ncwrite.ne.nf90_noerr) THEN
2576	WRITE (stdout,20) TRIM(ncvname), TRIM(ncname)
2577	exit_flag=3
2578	ioerror=mp_ncwrite
2579	EXIT
2580	END IF
2581	END DO
2582	END IF
2583	!
2584	! Otherwise, send data to master node.
2585	!
2586	ELSE
2587	np=(UB1-LB1+1)*(UB2-LB2+1)
2588	CALL mpi_isend (A(LB1:,LB2:), np, MP_FLOAT, MyMaster, MyRank+5, &
2589	& OCN_COMM_WORLD, request, MyError)
2590	CALL mpi_wait (request, status, MyError)
2591	IF (MyError.ne.MPI_SUCCESS) THEN
2592	CALL mpi_error_string (MyError, string, Lstr, Serror)
2593	Lstr=LEN_TRIM(string)
2594	WRITE (stdout,10) 'MPI_ISEND', MyRank, MyError, string(1:Lstr)
2595	exit_flag=2
2596	RETURN
2597	END IF
2598	END IF
2599	!
2600	! Broadcast error flags to all nodes.
2601	!
2602	ibuffer(1)=exit_flag
2603	ibuffer(2)=ioerror
2604	CALL mp_bcasti (ng, model, ibuffer)
2605	exit_flag=ibuffer(1)
2606	ioerror=ibuffer(2)
2607	!
2608	! Deallocate receive buffer.
2609	!
2610	IF (allocated(Arecv).and.(MyRank.eq.MyMaster)) THEN
2611	deallocate (Arecv)
2612	END IF
2613
2614	# ifdef PROFILE
2615	!
2616	!-----------------------------------------------------------------------
2617	! Turn on time clocks.
2618	!-----------------------------------------------------------------------
2619	!
2620	CALL wclock_off (ng, model, 44)
2621	# endif
2622
2623	10 FORMAT (/,' MP_NCWRITE - error during ',a,' call, Node = ', &
2624	& i3.3,' Error = ',i3,/,13x,a)
2625	20 FORMAT (/,' MP_NCWRITE - error while writing variable: ', &
2626	& a,/,13x,'in file: ',a)
2627	30 FORMAT (/,' MP_NCWRITE - error while inquiring ID for variable: ',&
2628	& a,/,13x,'in file: ',a)
2629
2630	RETURN
2631	END FUNCTION mp_ncwrite
2632
2633	SUBROUTINE mp_reduce_0d (ng, model, Asize, A, op_handle)
2634	!
2635	!***********************************************************************
2636	! !
2637	! This routine collects and reduces requested variables from all !
2638	! nodes in the group. Then, it broadcasts reduced variables to !
2639	! all nodes in the group. !
2640	! !
2641	! On Input: !
2642	! !
2643	! ng Nested grid number. !
2644	! model Calling model identifier. !
2645	! Asize Number of scalar variables to reduce. !
2646	! A Vector of scalar variables to reduce. !
2647	! op_handle Reduction operation handle (string). The following !
2648	! reduction operations are supported: !
2649	! 'MIN', 'MAX', 'SUM' !
2650	! !
2651	! On Output: !
2652	! !
2653	! A Vector of reduced scalar variables. !
2654	! !
2655	!***********************************************************************
2656	!
2657	USE mod_param
2658	USE mod_parallel
2659	USE mod_iounits
2660	USE mod_scalars
2661	!
2662	implicit none
2663	!
2664	! Imported variable declarations.
2665	!
2666	integer, intent(in) :: ng, model, Asize
2667
2668	character (len=*), intent(in) :: op_handle
2669
2670	real(r8), intent(inout) :: A
2671	!
2672	! Local variable declarations.
2673	!
2674	integer :: Lstr, MyError, Serror
2675	integer :: handle, i, rank, request
2676
2677	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
2678
2679	integer, dimension(MPI_STATUS_SIZE) :: Rstatus
2680	integer, dimension(MPI_STATUS_SIZE) :: Sstatus
2681
2682	real(r8) :: Areduce
2683	real(r8) :: Asend
2684	real(r8), dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
2685
2686	character (len=MPI_MAX_ERROR_STRING) :: string
2687
2688	# ifdef PROFILE
2689	!
2690	!-----------------------------------------------------------------------
2691	! Turn on time clocks.
2692	!-----------------------------------------------------------------------
2693	!
2694	CALL wclock_on (ng, model, 43)
2695	# endif
2696	!
2697	!-----------------------------------------------------------------------
2698	! Collect and reduce requested scalar variables.
2699	!-----------------------------------------------------------------------
2700	!
2701	! Pack data to reduce.
2702	!
2703	Asend=A
2704	!
2705	! Collect and reduce.
2706	!
2707	# if defined REDUCE_ALLREDUCE
2708	IF (op_handle(1:3).eq.'MIN') THEN
2709	handle=MPI_MIN
2710	ELSE IF (op_handle(1:3).eq.'MAX') THEN
2711	handle=MPI_MAX
2712	ELSE IF (op_handle(1:3).eq.'SUM') THEN
2713	handle=MPI_SUM
2714	END IF
2715	CALL mpi_allreduce (Asend, Areduce, 1, MP_FLOAT, handle, &
2716	& OCN_COMM_WORLD, MyError)
2717	IF (MyError.ne.MPI_SUCCESS) THEN
2718	CALL mpi_error_string (MyError, string, Lstr, Serror)
2719	Lstr=LEN_TRIM(string)
2720	WRITE (stdout,10) 'MPI_ALLREDUCE', MyRank, MyError, &
2721	& string(1:Lstr)
2722	exit_flag=2
2723	RETURN
2724	END IF
2725	# elif defined REDUCE_ALLGATHER
2726	CALL mpi_allgather (Asend, 1, MP_FLOAT, &
2727	& Arecv, 1, MP_FLOAT, &
2728	& OCN_COMM_WORLD, MyError)
2729	IF (MyError.ne.MPI_SUCCESS) THEN
2730	CALL mpi_error_string (MyError, string, Lstr, Serror)
2731	Lstr=LEN_TRIM(string)
2732	WRITE (stdout,10) 'MPI_ALLGATHER', MyRank, MyError, &
2733	& string(1:Lstr)
2734	exit_flag=2
2735	RETURN
2736	END IF
2737	Areduce=Arecv(0)
2738	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2739	IF (op_handle(1:3).eq.'MIN') THEN
2740	Areduce=MIN(Areduce,Arecv(rank))
2741	ELSE IF (op_handle(1:3).eq.'MAX') THEN
2742	Areduce=MAX(Areduce,Arecv(rank))
2743	ELSE IF (op_handle(1:3).eq.'SUM') THEN
2744	Areduce=Areduce+Arecv(rank)
2745	END IF
2746	END DO
2747	# else
2748	IF (MyRank.eq.MyMaster) THEN
2749	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2750	CALL mpi_irecv (Arecv(rank), 1, MP_FLOAT, rank, &
2751	& rank+500, OCN_COMM_WORLD, Rrequest(rank), &
2752	& MyError)
2753	END DO
2754	Areduce=Asend
2755	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2756	CALL mpi_wait (Rrequest(rank), Rstatus, MyError)
2757	IF (MyError.ne.MPI_SUCCESS) THEN
2758	CALL mpi_error_string (MyError, string, Lstr, Serror)
2759	Lstr=LEN_TRIM(string)
2760	WRITE (stdout,10) 'MPI_IRECV', rank, Rerror, string(1:Lstr)
2761	exit_flag=2
2762	RETURN
2763	END IF
2764	IF (op_handle(1:3).eq.'MIN') THEN
2765	Areduce=MIN(Areduce,Arecv(rank))
2766	ELSE IF (op_handle(1:3).eq.'MAX') THEN
2767	Areduce=MAX(Areduce,Arecv(rank))
2768	ELSE IF (op_handle(1:3).eq.'SUM') THEN
2769	Areduce=Areduce+Arecv(rank)
2770	END IF
2771	END DO
2772	ELSE
2773	CALL mpi_isend (Asend, 1, MP_FLOAT, MyMaster, MyRank+500, &
2774	& OCN_COMM_WORLD, request, MyError)
2775	CALL mpi_wait (request, Sstatus, MyError)
2776	IF (Serror.ne.MPI_SUCCESS) THEN
2777	CALL mpi_error_string (MyError, string, Lstr, Serror)
2778	Lstr=LEN_TRIM(string)
2779	WRITE (stdout,10) 'MPI_ISEND', MyRank, Serror, string(1:Lstr)
2780	exit_flag=2
2781	RETURN
2782	END IF
2783	END IF
2784	!
2785	! Broadcast reduced variables from process to all processes in the
2786	! group.
2787	!
2788	CALL mpi_bcast (Areduce, 1, MP_FLOAT, MyMaster, &
2789	& OCN_COMM_WORLD, MyError)
2790	IF (Serror.ne.MPI_SUCCESS) THEN
2791	CALL mpi_error_string (MyError, string, Lstr, Serror)
2792	Lstr=LEN_TRIM(string)
2793	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
2794	exit_flag=2
2795	RETURN
2796	END IF
2797	# endif
2798	10 FORMAT (/,' MP_REDUCE_0D - error during ',a,' call, Node = ', &
2799	& i3.3,' Error = ',i3,/,16x,a)
2800	!
2801	! Unpack.
2802	!
2803	A=Areduce
2804	# ifdef PROFILE
2805	!
2806	!-----------------------------------------------------------------------
2807	! Turn off time clocks.
2808	!-----------------------------------------------------------------------
2809	!
2810	CALL wclock_off (ng, model, 43)
2811	# endif
2812
2813	RETURN
2814	END SUBROUTINE mp_reduce_0d
2815
2816	SUBROUTINE mp_reduce_1d (ng, model, Asize, A, op_handle)
2817	!
2818	!***********************************************************************
2819	! !
2820	! This routine collects and reduces requested variables from all !
2821	! nodes in the group. Then, it broadcasts reduced variables to !
2822	! all nodes in the group. !
2823	! !
2824	! On Input: !
2825	! !
2826	! ng Nested grid number. !
2827	! model Calling model identifier. !
2828	! Asize Number of scalar variables to reduce. !
2829	! A Vector of scalar variables to reduce. !
2830	! op_handle Reduction operation handle (string). The following !
2831	! reduction operations are supported: !
2832	! 'MIN', 'MAX', 'SUM' !
2833	! !
2834	! On Output: !
2835	! !
2836	! A Vector of reduced scalar variables. !
2837	! !
2838	!***********************************************************************
2839	!
2840	USE mod_param
2841	USE mod_parallel
2842	USE mod_iounits
2843	USE mod_scalars
2844	!
2845	implicit none
2846	!
2847	! Imported variable declarations.
2848	!
2849	integer, intent(in) :: ng, model, Asize
2850
2851	character (len=*), intent(in) :: op_handle(Asize)
2852
2853	real(r8), intent(inout) :: A(Asize)
2854	!
2855	! Local variable declarations.
2856	!
2857	integer :: Lstr, MyError, Serror
2858	integer :: handle, i, rank, request
2859
2860	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
2861
2862	integer, dimension(MPI_STATUS_SIZE) :: Rstatus
2863	integer, dimension(MPI_STATUS_SIZE) :: Sstatus
2864
2865	real(r8), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
2866	real(r8), dimension(Asize) :: Areduce
2867	real(r8), dimension(Asize) :: Asend
2868
2869	character (len=MPI_MAX_ERROR_STRING) :: string
2870
2871	# ifdef PROFILE
2872	!
2873	!-----------------------------------------------------------------------
2874	! Turn on time clocks.
2875	!-----------------------------------------------------------------------
2876	!
2877	CALL wclock_on (ng, model, 43)
2878	# endif
2879	!
2880	!-----------------------------------------------------------------------
2881	! Collect and reduce requested scalar variables.
2882	!-----------------------------------------------------------------------
2883	!
2884	! Pack data to reduce.
2885	!
2886	DO i=1,Asize
2887	Asend(i)=A(i)
2888	END DO
2889	!
2890	! Collect and reduce.
2891	!
2892	# if defined REDUCE_ALLREDUCE
2893	DO i=1,Asize
2894	IF (op_handle(i)(1:3).eq.'MIN') THEN
2895	handle=MPI_MIN
2896	ELSE IF (op_handle(i)(1:3).eq.'MAX') THEN
2897	handle=MPI_MAX
2898	ELSE IF (op_handle(i)(1:3).eq.'SUM') THEN
2899	handle=MPI_SUM
2900	END IF
2901	CALL mpi_allreduce (Asend(i), Areduce(i), 1, MP_FLOAT, handle, &
2902	& OCN_COMM_WORLD, MyError)
2903	IF (MyError.ne.MPI_SUCCESS) THEN
2904	CALL mpi_error_string (MyError, string, Lstr, Serror)
2905	Lstr=LEN_TRIM(string)
2906	WRITE (stdout,10) 'MPI_ALLREDUCE', MyRank, MyError, &
2907	& string(1:Lstr)
2908	exit_flag=2
2909	RETURN
2910	END IF
2911	END DO
2912	# elif defined REDUCE_ALLGATHER
2913	CALL mpi_allgather (Asend, Asize, MP_FLOAT, &
2914	& Arecv, Asize, MP_FLOAT, &
2915	& OCN_COMM_WORLD, MyError)
2916	IF (MyError.ne.MPI_SUCCESS) THEN
2917	CALL mpi_error_string (MyError, string, Lstr, Serror)
2918	Lstr=LEN_TRIM(string)
2919	WRITE (stdout,10) 'MPI_ALLGATHER', MyRank, MyError, &
2920	& string(1:Lstr)
2921	exit_flag=2
2922	RETURN
2923	END IF
2924	DO i=1,Asize
2925	Areduce(i)=Arecv(i,0)
2926	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2927	IF (op_handle(i)(1:3).eq.'MIN') THEN
2928	Areduce(i)=MIN(Areduce(i),Arecv(i,rank))
2929	ELSE IF (op_handle(i)(1:3).eq.'MAX') THEN
2930	Areduce(i)=MAX(Areduce(i),Arecv(i,rank))
2931	ELSE IF (op_handle(i)(1:3).eq.'SUM') THEN
2932	Areduce(i)=Areduce(i)+Arecv(i,rank)
2933	END IF
2934	END DO
2935	END DO
2936	# else
2937	IF (MyRank.eq.MyMaster) THEN
2938	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2939	CALL mpi_irecv (Arecv(1,rank), Asize, MP_FLOAT, rank, &
2940	& rank+500, OCN_COMM_WORLD, Rrequest(rank), &
2941	& MyError)
2942	END DO
2943	DO i=1,Asize
2944	Areduce(i)=Asend(i)
2945	END DO
2946	DO rank=1,NtileI(ng)*NtileJ(ng)-1
2947	CALL mpi_wait (Rrequest(rank), Rstatus, MyError)
2948	IF (MyError.ne.MPI_SUCCESS) THEN
2949	CALL mpi_error_string (MyError, string, Lstr, Serror)
2950	Lstr=LEN_TRIM(string)
2951	WRITE (stdout,10) 'MPI_IRECV', rank, Rerror, string(1:Lstr)
2952	exit_flag=2
2953	RETURN
2954	END IF
2955	DO i=1,Asize
2956	IF (op_handle(i)(1:3).eq.'MIN') THEN
2957	Areduce(i)=MIN(Areduce(i),Arecv(i,rank))
2958	ELSE IF (op_handle(i)(1:3).eq.'MAX') THEN
2959	Areduce(i)=MAX(Areduce(i),Arecv(i,rank))
2960	ELSE IF (op_handle(i)(1:3).eq.'SUM') THEN
2961	Areduce(i)=Areduce(i)+Arecv(i,rank)
2962	END IF
2963	END DO
2964	END DO
2965	ELSE
2966	CALL mpi_isend (Asend, Asize, MP_FLOAT, MyMaster, MyRank+500, &
2967	& OCN_COMM_WORLD, request, MyError)
2968	CALL mpi_wait (request, Sstatus, MyError)
2969	IF (Serror.ne.MPI_SUCCESS) THEN
2970	CALL mpi_error_string (MyError, string, Lstr, Serror)
2971	Lstr=LEN_TRIM(string)
2972	WRITE (stdout,10) 'MPI_ISEND', MyRank, Serror, string(1:Lstr)
2973	exit_flag=2
2974	RETURN
2975	END IF
2976	END IF
2977	!
2978	! Broadcast reduced variables from process to all processes in the
2979	! group.
2980	!
2981	CALL mpi_bcast (Areduce, Asize, MP_FLOAT, MyMaster, &
2982	& OCN_COMM_WORLD, MyError)
2983	IF (Serror.ne.MPI_SUCCESS) THEN
2984	CALL mpi_error_string (MyError, string, Lstr, Serror)
2985	Lstr=LEN_TRIM(string)
2986	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
2987	exit_flag=2
2988	RETURN
2989	END IF
2990	# endif
2991	10 FORMAT (/,' MP_REDUCE_1D - error during ',a,' call, Node = ', &
2992	& i3.3,' Error = ',i3,/,16x,a)
2993	!
2994	! Unpack.
2995	!
2996	DO i=1,Asize
2997	A(i)=Areduce(i)
2998	END DO
2999	# ifdef PROFILE
3000	!
3001	!-----------------------------------------------------------------------
3002	! Turn off time clocks.
3003	!-----------------------------------------------------------------------
3004	!
3005	CALL wclock_off (ng, model, 43)
3006	# endif
3007
3008	RETURN
3009	END SUBROUTINE mp_reduce_1d
3010
3011	SUBROUTINE mp_scatter2d (ng, model, LBi, UBi, LBj, UBj, &
3012	& Nghost, gtype, Amin, Amax, &
3013	# if defined READ_WATER && defined MASKING
3014	& NWpts, IJ_water, &
3015	# endif
3016	& Npts, A, Aout)
3017	!
3018	!***********************************************************************
3019	! !
3020	! This routine broadcasts input global data, packed as 1D real array, !
3021	! to each spawned MPI node. Because this routine is also used by the !
3022	! adjoint model, the ghost-points in the halo region are NOT updated !
3023	! in the ouput tile array (Aout). It is used by the master node to !
3024	! scatter input global data to each tiled node. !
3025	! !
3026	! On Input: !
3027	! !
3028	! ng Nested grid number. !
3029	! model Calling model identifier. !
3030	! LBi I-dimension Lower bound. !
3031	! UBi I-dimension Upper bound. !
3032	! LBj J-dimension Lower bound. !
3033	! UBj J-dimension Upper bound. !
3034	! Nghost Number of ghost-points in the halo region. !
3035	! gtype C-grid type. If negative and Land-Sea mask is !
3036	! available, only water-points are processed. !
3037	! Amin Input array minimum value. !
3038	! Amax Input array maximum value. !
3039	! NWpts Number of water points. !
3040	! IJ_water IJ-indices for water points. !
3041	! Npts Number of points to processes in A. !
3042	! A Input global data from each node packed into 1D array !
3043	! in column-major order. That is, in the same way !
3044	! that Fortran multi-dimensional arrays are stored !
3045	! in memory. !
3046	! Npts Number of points to processes in A. !
3047	! !
3048	! On Output: !
3049	! !
3050	! Aout 2D tiled, floating-point array. !
3051	! !
3052	!***********************************************************************
3053	!
3054	USE mod_param
3055	USE mod_parallel
3056	USE mod_iounits
3057	USE mod_ncparam
3058	USE mod_scalars
3059	!
3060	implicit none
3061	!
3062	! Imported variable declarations.
3063	!
3064	integer, intent(in) :: ng, model
3065	integer, intent(in) :: LBi, UBi, LBj, UBj
3066	integer, intent(in) :: Nghost, gtype, Npts
3067
3068	# if defined READ_WATER && defined MASKING
3069	integer, intent(in) :: NWpts
3070	integer, intent(in) :: IJ_water(NWpts)
3071	# endif
3072	real(r8), intent(inout) :: Amin, Amax
3073	real(r8), intent(inout) :: A(Npts+2)
3074	real(r8), intent(out) :: Aout(LBi:UBi,LBj:UBj)
3075	!
3076	! Local variable declarations.
3077	!
3078	integer :: Io, Ie, Jo, Je, Ioff, Joff
3079	integer :: Ilen, Jlen, IJlen
3080	integer :: Lstr, MyError, MySize, MyType, Serror, rank
3081	integer :: i, ic, ij, j, jc, mc, nc
3082
3083	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Imin, Imax
3084	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Jmin, Jmax
3085	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Itile, Jtile
3086
3087	real(r8), dimension((Lm(ng)+2)*(Mm(ng)+2)) :: Arecv
3088
3089	character (len=MPI_MAX_ERROR_STRING) :: string
3090
3091	# ifdef PROFILE
3092	!
3093	!-----------------------------------------------------------------------
3094	! Turn on time clocks.
3095	!-----------------------------------------------------------------------
3096	!
3097	CALL wclock_on (ng, model, 45)
3098	# endif
3099	!
3100	!-----------------------------------------------------------------------
3101	! Set horizontal starting and ending indices for parallel domain
3102	! partitions in the XI- and ETA-directions.
3103	!-----------------------------------------------------------------------
3104	!
3105	! Set first and last grid point according to staggered C-grid
3106	! classification. The, set 1D counter offsets.
3107	!
3108	Io=0
3109	Ie=Lm(ng)+1
3110	Jo=0
3111	Je=Mm(ng)+1
3112	MyType=ABS(gtype)
3113	IF ((MyType.eq.p2dvar).or.(MyType.eq.u2dvar).or. &
3114	& (MyType.eq.p3dvar).or.(MyType.eq.u3dvar)) Io=1
3115	IF ((MyType.eq.p2dvar).or.(MyType.eq.v2dvar).or. &
3116	& (MyType.eq.p3dvar).or.(MyType.eq.v3dvar)) Jo=1
3117	IF (Io.eq.0) THEN
3118	Ioff=1
3119	ELSE
3120	Ioff=0
3121	END IF
3122	IF (Jo.eq.0) THEN
3123	Joff=0
3124	ELSE
3125	Joff=1
3126	END IF
3127	Ilen=Ie-Io+1
3128	Jlen=Je-Jo+1
3129	IJlen=Ilen*Jlen
3130	!
3131	! Set physical, non-overlaping (no ghost-points) ranges according to
3132	! tile rank.
3133	!
3134	DO rank=0,NtileI(ng)*NtileJ(ng)-1
3135	CALL get_bounds (ng, rank, gtype, Nghost, &
3136	& Itile(rank), Jtile(rank), &
3137	& Imin(rank), Imax(rank), &
3138	& Jmin(rank), Jmax(rank))
3139	END DO
3140	!
3141	! Size of broadcast buffer.
3142	!
3143	IF (gtype.gt.0) THEN
3144	MySize=IJlen
3145	ELSE
3146	MySize=Npts
3147	END IF
3148	!
3149	! Initialize local array to avoid denormalized numbers. This
3150	! facilitates processing and debugging.
3151	!
3152	Arecv=0.0_r8
3153	!
3154	!-----------------------------------------------------------------------
3155	! Scatter requested array data.
3156	!-----------------------------------------------------------------------
3157	!
3158	! If master processor, append minimum and maximum values to the end of
3159	! the buffer.
3160	!
3161	IF (MyRank.eq.MyMaster) Then
3162	A(MySize+1)=Amin
3163	A(MySize+2)=Amax
3164	END IF
3165	MySize=MySize+2
3166	!
3167	! Broadcast data to all processes in the group, itself included.
3168	!
3169	CALL mpi_bcast (A, MySize, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
3170	& MyError)
3171	IF (MyError.ne.MPI_SUCCESS) THEN
3172	CALL mpi_error_string (MyError, string, Lstr, Serror)
3173	Lstr=LEN_TRIM(string)
3174	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
3175	10 FORMAT (/,' MP_SCATTER2D - error during ',a,' call, Node = ', &
3176	& i3.3, ' Error = ',i3,/,15x,a)
3177	exit_flag=2
3178	RETURN
3179	END IF
3180	!
3181	! If water points only, fill land points.
3182	!
3183	IF (gtype.gt.0) THEN
3184	DO nc=1,MySize-2
3185	Arecv(nc)=A(nc)
3186	END DO
3187	# if defined READ_WATER && defined MASKING
3188	ELSE
3189	ij=0
3190	mc=0
3191	nc=0
3192	DO j=Jo,Je
3193	jc=(j-Joff)*Ilen
3194	DO i=Io,Ie
3195	ij=ij+1
3196	ic=i+Ioff+jc
3197	IF (IJ_water(mc+1).eq.ij) THEN
3198	mc=mc+1
3199	nc=nc+1
3200	Arecv(ic)=A(nc)
3201	ELSE
3202	Arecv(ic)=0.0_r8
3203	ENDIF
3204	END DO
3205	END DO
3206	# endif
3207	END IF
3208	!
3209	! Unpack data buffer.
3210	!
3211	DO j=Jmin(MyRank),Jmax(MyRank)
3212	jc=(j-Joff)*Ilen
3213	DO i=Imin(MyRank),Imax(MyRank)
3214	ic=i+Ioff+jc
3215	Aout(i,j)=Arecv(ic)
3216	END DO
3217	END DO
3218	Amin=A(MySize-1)
3219	Amax=A(MySize)
3220	# ifdef PROFILE
3221	!
3222	!-----------------------------------------------------------------------
3223	! Turn off time clocks.
3224	!-----------------------------------------------------------------------
3225	!
3226	CALL wclock_off (ng, model, 45)
3227	# endif
3228
3229	RETURN
3230	END SUBROUTINE mp_scatter2d
3231
3232	SUBROUTINE mp_scatter3d (ng, model, LBi, UBi, LBj, UBj, LBk, UBk, &
3233	& Nghost, gtype, Amin, Amax, &
3234	# if defined READ_WATER && defined MASKING
3235	& NWpts, IJ_water, &
3236	# endif
3237	& Npts, A, Aout)
3238	!
3239	!***********************************************************************
3240	! !
3241	! This routine broadcasts input global data, packed as 1D real array, !
3242	! to each spawned MPI node. Because this routine is also used by the !
3243	! adjoint model, the ghost-points in the halo region are NOT updated !
3244	! in the ouput tile array (Aout). It is used by the master node to !
3245	! scatter input global data to each tiled node. !
3246	! !
3247	! On Input: !
3248	! !
3249	! ng Nested grid number. !
3250	! model Calling model identifier. !
3251	! LBi I-dimension Lower bound. !
3252	! UBi I-dimension Upper bound. !
3253	! LBj J-dimension Lower bound. !
3254	! UBj J-dimension Upper bound. !
3255	! LBk K-dimension Lower bound. !
3256	! UBk K-dimension Upper bound. !
3257	! Nghost Number of ghost-points in the halo region. !
3258	! gtype C-grid type. If negative and Land-Sea mask is !
3259	! available, only water-points are processed. !
3260	! Amin Input array minimum value. !
3261	! Amax Input array maximum value. !
3262	! NWpts Number of water points. !
3263	! IJ_water IJ-indices for water points. !
3264	! Npts Number of points to processes in A. !
3265	! A Input global data from each node packed into 1D array !
3266	! in column-major order. That is, in the same way !
3267	! that Fortran multi-dimensional arrays are stored !
3268	! in memory. !
3269	! Npts Number of points to processes in A. !
3270	! !
3271	! On Output: !
3272	! !
3273	! Aout 3D tiled, floating-point array. !
3274	! !
3275	!***********************************************************************
3276	!
3277	USE mod_param
3278	USE mod_parallel
3279	USE mod_iounits
3280	USE mod_ncparam
3281	USE mod_scalars
3282	!
3283	implicit none
3284	!
3285	! Imported variable declarations.
3286	!
3287	integer, intent(in) :: ng, model
3288	integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
3289	integer, intent(in) :: Nghost, gtype, Npts
3290
3291	# if defined READ_WATER && defined MASKING
3292	integer, intent(in) :: NWpts
3293	integer, intent(in) :: IJ_water(NWpts)
3294	# endif
3295	real(r8), intent(inout) :: Amin, Amax
3296	real(r8), intent(inout) :: A(Npts+2)
3297	real(r8), intent(out) :: Aout(LBi:UBi,LBj:UBj,LBk:UBk)
3298	!
3299	! Local variable declarations.
3300	!
3301	integer :: Io, Ie, Jo, Je, Ioff, Joff, Koff
3302	integer :: Ilen, Jlen, Klen, IJlen
3303	integer :: Lstr, MyError, MySize, MyType, Serror, rank
3304	integer :: i, ic, ij, j, jc, k, kc, mc, nc
3305
3306	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Imin, Imax
3307	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Jmin, Jmax
3308	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Itile, Jtile
3309
3310	real(r8), dimension((Lm(ng)+2)(Mm(ng)+2)(UBk-LBk+1)) :: Arecv
3311
3312	character (len=MPI_MAX_ERROR_STRING) :: string
3313
3314	# ifdef PROFILE
3315	!
3316	!-----------------------------------------------------------------------
3317	! Turn on time clocks.
3318	!-----------------------------------------------------------------------
3319	!
3320	CALL wclock_on (ng, model, 45)
3321	# endif
3322	!
3323	!-----------------------------------------------------------------------
3324	! Set horizontal starting and ending indices for parallel domain
3325	! partitions in the XI- and ETA-directions.
3326	!-----------------------------------------------------------------------
3327	!
3328	! Set first and last grid point according to staggered C-grid
3329	! classification. The, set 1D counter offsets.
3330	!
3331	Io=0
3332	Ie=Lm(ng)+1
3333	Jo=0
3334	Je=Mm(ng)+1
3335	MyType=ABS(gtype)
3336	IF ((MyType.eq.p2dvar).or.(MyType.eq.u2dvar).or. &
3337	& (MyType.eq.p3dvar).or.(MyType.eq.u3dvar)) Io=1
3338	IF ((MyType.eq.p2dvar).or.(MyType.eq.v2dvar).or. &
3339	& (MyType.eq.p3dvar).or.(MyType.eq.v3dvar)) Jo=1
3340	IF (Io.eq.0) THEN
3341	Ioff=1
3342	ELSE
3343	Ioff=0
3344	END IF
3345	IF (Jo.eq.0) THEN
3346	Joff=0
3347	ELSE
3348	Joff=1
3349	END IF
3350	IF (LBk.eq.0) THEN
3351	Koff=0
3352	ELSE
3353	Koff=1
3354	END IF
3355	Ilen=Ie-Io+1
3356	Jlen=Je-Jo+1
3357	Klen=UBk-LBk+1
3358	IJlen=Ilen*Jlen
3359	!
3360	! Set physical, non-overlaping (no ghost-points) ranges according to
3361	! tile rank.
3362	!
3363	DO rank=0,NtileI(ng)*NtileJ(ng)-1
3364	CALL get_bounds (ng, rank, gtype, Nghost, &
3365	& Itile(rank), Jtile(rank), &
3366	& Imin(rank), Imax(rank), &
3367	& Jmin(rank), Jmax(rank))
3368	END DO
3369	!
3370	! Size of broadcast buffer.
3371	!
3372	IF (gtype.gt.0) THEN
3373	MySize=IJlen*Klen
3374	ELSE
3375	MySize=Npts
3376	END IF
3377	!
3378	! Initialize local array to avoid denormalized numbers. This
3379	! facilitates processing and debugging.
3380	!
3381	Arecv=0.0_r8
3382	!
3383	!-----------------------------------------------------------------------
3384	! Scatter requested array data.
3385	!-----------------------------------------------------------------------
3386	!
3387	! If master processor, append minimum and maximum values to the end of
3388	! the buffer.
3389	!
3390	IF (MyRank.eq.MyMaster) Then
3391	A(MySize+1)=Amin
3392	A(MySize+2)=Amax
3393	END IF
3394	MySize=MySize+2
3395	!
3396	! Broadcast data to all processes in the group, itself included.
3397	!
3398	CALL mpi_bcast (A, MySize, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
3399	& MyError)
3400	IF (MyError.ne.MPI_SUCCESS) THEN
3401	CALL mpi_error_string (MyError, string, Lstr, Serror)
3402	Lstr=LEN_TRIM(string)
3403	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
3404	10 FORMAT (/,' MP_SCATTER3D - error during ',a,' call, Node = ', &
3405	& i3.3, ' Error = ',i3,/,15x,a)
3406	exit_flag=2
3407	RETURN
3408	END IF
3409	!
3410	! If water points only, fill land points.
3411	!
3412	IF (gtype.gt.0) THEN
3413	DO nc=1,MySize-2
3414	Arecv(nc)=A(nc)
3415	END DO
3416	# if defined READ_WATER && defined MASKING
3417	ELSE
3418	nc=0
3419	DO k=LBk,UBk
3420	kc=(k-Koff)*IJlen
3421	ij=0
3422	mc=0
3423	DO j=Jo,Je
3424	jc=(j-Joff)*Ilen+kc
3425	DO i=Io,Ie
3426	ij=ij+1
3427	ic=i+Ioff+jc
3428	IF (IJ_water(mc+1).eq.ij) THEN
3429	mc=mc+1
3430	nc=nc+1
3431	Arecv(ic)=A(nc)
3432	ELSE
3433	Arecv(ic)=0.0_r8
3434	ENDIF
3435	END DO
3436	END DO
3437	END DO
3438	# endif
3439	END IF
3440	!
3441	! Unpack data buffer.
3442	!
3443	DO k=LBk,UBk
3444	kc=(k-Koff)*IJlen
3445	DO j=Jmin(MyRank),Jmax(MyRank)
3446	jc=(j-Joff)*Ilen+kc
3447	DO i=Imin(MyRank),Imax(MyRank)
3448	ic=i+Ioff+jc
3449	Aout(i,j,k)=Arecv(ic)
3450	END DO
3451	END DO
3452	END DO
3453	Amin=A(MySize-1)
3454	Amax=A(MySize)
3455	# ifdef PROFILE
3456	!
3457	!-----------------------------------------------------------------------
3458	! Turn off time clocks.
3459	!-----------------------------------------------------------------------
3460	!
3461	CALL wclock_off (ng, model, 45)
3462	# endif
3463
3464	RETURN
3465	END SUBROUTINE mp_scatter3d
3466
3467	SUBROUTINE mp_scatter_state (ng, model, Nstr, Nend, Asize, &
3468	& A, Aout)
3469	!
3470	!***********************************************************************
3471	! !
3472	! This routine scatters (global to threaded) state data to all nodes !
3473	! in the group. Before this can be done, the global data needs to be !
3474	! collected from all the nodes by the master. This is achieved by !
3475	! summing the input values at each point. This routine is used to !
3476	! pack the state data for the GST analysis propagators. !
3477	! !
3478	! On Input: !
3479	! !
3480	! ng Nested grid number. !
3481	! model Calling model identifier. !
3482	! Nstr Threaded array lower bound. !
3483	! Nend Threaded array upper bound. !
3484	! Asize Size of the . !
3485	! A Threaded 1D array process. !
3486	! !
3487	! On Output: !
3488	! !
3489	! A Collected data from all nodes. !
3490	! Aout Threaded block of data. !
3491	! !
3492	!***********************************************************************
3493	!
3494	USE mod_param
3495	USE mod_parallel
3496	USE mod_iounits
3497	USE mod_ncparam
3498	USE mod_scalars
3499	!
3500	implicit none
3501	!
3502	! Imported variable declarations.
3503	!
3504	integer, intent(in) :: ng, model
3505	integer, intent(in) :: Nstr, Nend, Asize
3506
3507	real(r8), intent(inout) :: A(Asize)
3508
3509	real(r8), intent(out) :: Aout(Nstr:Nend)
3510	!
3511	! Local variable declarations.
3512	!
3513	integer :: Lstr, MyError, Serror
3514	integer :: i, rank, request
3515
3516	integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
3517
3518	integer, dimension(MPI_STATUS_SIZE) :: status
3519
3520	real(r8), allocatable :: Arecv(:)
3521
3522	character (len=MPI_MAX_ERROR_STRING) :: string
3523
3524	# ifdef PROFILE
3525	!
3526	!-----------------------------------------------------------------------
3527	! Turn on time clocks.
3528	!-----------------------------------------------------------------------
3529	!
3530	CALL wclock_on (ng, model, 44)
3531	# endif
3532	!
3533	!-----------------------------------------------------------------------
3534	! Collect data blocks from all nodes and scatter the data to all nodes.
3535	!-----------------------------------------------------------------------
3536	!
3537	! All nodes have distinct pieces of the data and zero everywhere else.
3538	! So the strategy here is for the master node to receive the data from
3539	! the other nodes (excluding itself) and accumulate the sum at each
3540	! point. Then, the master node broadcast (itself included) its copy of
3541	! the accumlated data to other the nodes in the group. After this, each
3542	! node loads only the required block of the data into output array.
3543	!
3544	! Notice that only the master node allocates the recieving buffer
3545	! (Arecv). It also receives only buffer at the time to avoid having
3546	! a very large communication array. So here memory is more important
3547	! than time.
3548	!
3549	IF (MyRank.eq.MyMaster) THEN
3550	!
3551	! If master node, allocate and receive buffer.
3552	!
3553	IF (.not.allocated(Arecv)) THEN
3554	allocate (Arecv(Asize))
3555	END IF
3556	!
3557	! If master node, loop over other nodes to receive and accumulate the
3558	! data.
3559	!
3560	DO rank=1,NtileI(ng)*NtileJ(ng)-1
3561	CALL mpi_irecv (Arecv, Asize, MP_FLOAT, rank, rank+5, &
3562	& OCN_COMM_WORLD, Rrequest(rank), MyError)
3563	CALL mpi_wait (Rrequest(rank), status, MyError)
3564	IF (MyError.ne.MPI_SUCCESS) THEN
3565	CALL mpi_error_string (MyError, string, Lstr, Serror)
3566	Lstr=LEN_TRIM(string)
3567	WRITE (stdout,10) 'MPI_IRECV', rank, MyError, string(1:Lstr)
3568	10 FORMAT (/,' MP_SCATTER_STATE - error during ',a, &
3569	& ' call, Node = ', i3.3,' Error = ',i3,/,13x,a)
3570	exit_flag=2
3571	RETURN
3572	END IF
3573	DO i=1,Asize
3574	A(i)=A(i)+Arecv(i)
3575	END DO
3576	END DO
3577	!
3578	! Otherwise, send data to master node.
3579	!
3580	ELSE
3581	CALL mpi_isend (A, Asize, MP_FLOAT, MyMaster, MyRank+5, &
3582	& OCN_COMM_WORLD, request, MyError)
3583	CALL mpi_wait (request, status, MyError)
3584	IF (MyError.ne.MPI_SUCCESS) THEN
3585	CALL mpi_error_string (MyError, string, Lstr, Serror)
3586	Lstr=LEN_TRIM(string)
3587	WRITE (stdout,10) 'MPI_ISEND', MyRank, MyError, string(1:Lstr)
3588	exit_flag=2
3589	RETURN
3590	END IF
3591	END IF
3592	!
3593	! Broadcast accumulated (full) data to all nodes.
3594	!
3595	CALL mpi_bcast (A, Asize, MP_FLOAT, MyMaster, OCN_COMM_WORLD, &
3596	& MyError)
3597	IF (MyError.ne.MPI_SUCCESS) THEN
3598	CALL mpi_error_string (MyError, string, Lstr, Serror)
3599	Lstr=LEN_TRIM(string)
3600	WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr)
3601	exit_flag=2
3602	RETURN
3603	END IF
3604	!
3605	! Load appropriate data block into output array.
3606	!
3607	DO i=Nstr,Nend
3608	Aout(i)=A(i)
3609	END DO
3610
3611	# ifdef PROFILE
3612	!
3613	!-----------------------------------------------------------------------
3614	! Turn off time clocks.
3615	!-----------------------------------------------------------------------
3616	!
3617	CALL wclock_off (ng, model, 44)
3618	# endif
3619
3620	RETURN
3621	END SUBROUTINE mp_scatter_state
3622
3623	SUBROUTINE mp_dump (ng, tile, gtype, &
3624	& ILB, IUB, JLB, JUB, KLB, KUB, A, name)
3625	!
3626	!***********************************************************************
3627	! !
3628	! This routine is used to debug distributed-memory communications. !
3629	! It writes field into an ASCII file for further post-processing. !
3630	! !
3631	!***********************************************************************
3632	!
3633
3634	USE mod_param
3635	USE mod_parallel
3636	USE mod_ncparam
3637	!
3638	implicit none
3639	!
3640	! Imported variable declarations.
3641	!
3642	integer, intent(in) :: ng, tile, gtype
3643	integer, intent(in) :: ILB, IUB, JLB, JUB, KLB, KUB
3644
3645	real(r8), intent(in) :: A(ILB:IUB,JLB:JUB,KLB:KUB)
3646
3647	character (len=*) :: name
3648	!
3649	! Local variable declarations.
3650	!
3651	common /counter/ nc
3652	integer :: nc
3653
3654	logical, save :: first = .TRUE.
3655
3656	integer :: Imin, Imax, Ioff, Jmin, Jmax, Joff
3657	integer :: unit
3658
3659	# include "set_bounds.h"
3660	!
3661	!------------------------------------------------------------------------
3662	! Write out requested field.
3663	!------------------------------------------------------------------------
3664	!
3665	IF (first) THEN
3666	nc=0
3667	first=.FALSE.
3668	END IF
3669	nc=nc+1
3670	IF (Master) THEN
3671	WRITE (10,'(a,i3.3,a,a)') 'file ', nc, ': ', TRIM(name)
3672	CALL my_flush (10)
3673	END IF
3674	!
3675	! Write out field including ghost-points.
3676	!
3677	Imin=0
3678	Imax=Lm(ng)+1
3679	# ifdef EW_PERIODIC
3680	Ioff=3
3681	# else
3682	Ioff=1
3683	# endif
3684	Jmin=0
3685	Jmax=Mm(ng)+1
3686	# ifdef NS_PERIODIC
3687	Joff=3
3688	# else
3689	Joff=1
3690	# endif
3691	IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or. &
3692	& (gtype.eq.u2dvar).or.(gtype.eq.u3dvar)) THEN
3693	Imin=1
3694	END IF
3695	IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or. &
3696	& (gtype.eq.v2dvar).or.(gtype.eq.v3dvar)) THEN
3697	Jmin=1
3698	END IF
3699
3700	unit=(MyRank+1)*1000+nc
3701	WRITE (unit,*) ILB, IUB, JLB, JUB, KLB, KUB, &
3702	& Ioff, Joff, Imin, Imax, Jmin, Jmax, &
3703	& A(ILB:IUB,JLB:JUB,KLB:KUB)
3704	CALL my_flush (unit)
3705	!
3706	! Write out non-overlapping field.
3707	!
3708	Imin=IstrR
3709	Imax=IendR
3710	# ifdef EW_PERIODIC
3711	Ioff=2
3712	# else
3713	Ioff=1
3714	# endif
3715	Jmin=JstrR
3716	Jmax=JendR
3717	# ifdef NS_PERIODIC
3718	Joff=2
3719	# else
3720	Joff=1
3721	# endif
3722	IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or. &
3723	& (gtype.eq.u2dvar).or.(gtype.eq.u3dvar)) THEN
3724	Imin=Istr
3725	Ioff=Ioff-1
3726	END IF
3727	IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or. &
3728	& (gtype.eq.v2dvar).or.(gtype.eq.v3dvar)) THEN
3729	Jmin=Jstr
3730	Joff=Joff-1
3731	END IF
3732
3733	unit=(MyRank+1)*10000+nc
3734	WRITE (unit,*) Imin, Imax, Jmin, Jmax, KLB, KUB, &
3735	& Ioff, Joff, Imin, Imax, Jmin, Jmax, &
3736	& A(Imin:Imax,Jmin:Jmax,KLB:KUB)
3737	CALL my_flush (unit)
3738
3739	RETURN
3740	END SUBROUTINE mp_dump
3741
3742	SUBROUTINE mp_aggregate (ng, model, tindex, gtype, &
3743	& LBi, UBi, LBj, UBj, LBk, UBk, &
3744	# ifdef MASKING
3745	& Amask, &
3746	# endif
3747	& A)
3748	!
3749	!***********************************************************************
3750	! !
3751	! This routine is used to aggregate tiled data into a full 2D/3D !
3752	! array for debugging purposes. !
3753	! !
3754	!***********************************************************************
3755	!
3756	USE mod_param
3757	!
3758	implicit none
3759	!
3760	! Imported variable declarations.
3761	!
3762	integer, intent(in) :: ng, model, tindex, gtype
3763	integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
3764
3765	# ifdef MASKING
3766	real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
3767	# endif
3768	real(r8), intent(in) :: A(LBi:UBi,LBj:UBj,LBk:UBk)
3769	!
3770	! Local variable declarations.
3771	!
3772	integer :: Npts
3773
3774	real(r8) :: Ascl
3775
3776	real(r8), dimension(0:Lm(ng)+1,0:Mm(ng)+1,LBk:UBk) :: Aout
3777	!
3778	!------------------------------------------------------------------------
3779	! Aggregate all tile data into a single array.
3780	!------------------------------------------------------------------------
3781	!
3782	Ascl=1.0_r8
3783	CALL mp_gather3d (ng, model, LBi, UBi, LBj, UBj, LBk, UBk, &
3784	& tindex, gtype, Ascl, &
3785	# ifdef MASKING
3786	& Amask(LBi:,LBj:), &
3787	# endif
3788	& A(LBi:,LBj:,LBk:), &
3789	& Npts, Aout(0:,0:,LBk:))
3790
3791	RETURN
3792	END SUBROUTINE mp_aggregate
3793	#endif
3794	END MODULE distribute_mod

Download in other formats:

Original Format