forked from schism-dev/schism
-
Notifications
You must be signed in to change notification settings - Fork 0
/
schism_msgp.F90
4117 lines (3632 loc) · 167 KB
/
schism_msgp.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
! Copyright 2014 College of William and Mary
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
! Routines:
! parallel_init
! parallel_finalize
! parallel_abort
! parallel_barrier
! parallel_rrsync
! msgp_tables
! msgp_init
! Exchange routines for nodes/sides/elements
!===============================================================================
!===============================================================================
! SCHISM PARALLEL MESSAGE PASSING MODULE
!===============================================================================
!===============================================================================
module schism_msgp
!#ifdef USE_MPIMODULE
! use mpi
!#endif
use schism_glbl, only : rkind, llist_type,nvrt, &
&ne_global,ne,neg,nea,ielg,iegl,iegrpv,elnode,elside, &
&np_global,np,npg,npa,iplg,ipgl,nne,indel,dp, &
&ns_global,ns,nsg,nsa,islg,isgl,isdel,isidenode, &
&errmsg,fdb,lfdb,ntracers,msc2,mdc2,i34,nea2, &
&ielg2,iegl2,is_inter,iside_table,in_dir,out_dir,len_in_dir,len_out_dir
implicit none
!#ifndef USE_MPIMODULE
include 'mpif.h'
!#endif
private !Default scope is private
!-----------------------------------------------------------------------------
! Public data
!-----------------------------------------------------------------------------
integer,public,save :: nscribes ! # of I/O scribes (>=0)
integer,public,save :: task_id ! 1: compute; 2: I/O
integer,public,save :: myrank ! Rank of MPI compute task (0 base)
integer,public,save :: nproc ! Number of MPI compute tasks
integer,public,save :: myrank_schism ! Rank of MPI task from union world
integer,public,save :: nproc_schism ! Number of MPI tasks in union world
integer,public,save :: myrank_scribe ! Rank of MPI task from scribe world
integer,public,save :: nproc_scribe ! Number of MPI tasks from scribe world
integer,public,save :: ierr ! Return flag for MPI calls
integer,public,save :: istatus(MPI_STATUS_SIZE) ! Return status for MPI calls
integer,public,save :: comm ! MPI Communicator for compute only
integer,public,save :: comm_scribe ! MPI Communicator for scribes only
integer,public,save :: comm_schism ! Union Communicator for compute & scribes
integer,public,save :: itype = MPI_INTEGER ! MPI Integer Type
!#ifdef USE_SINGLE
! integer,public,save :: rtype = MPI_REAL4 ! MPI Real Type -- to match rkind
!#else
integer,public,save :: rtype = MPI_REAL8 ! MPI Real Type -- to match rkind
!#endif
integer,public,save :: nnbr ! Number of neighboring processors (elements)
integer,public,save,allocatable :: nbrrank(:) ! Rank of neighboring processors (elements)
integer,public,save,allocatable :: ranknbr(:) ! Mapping from MPI rank to neighbor index (elements)
integer,public,save :: nnbr_p ! Number of neighboring processors (nodes)
integer,public,save,allocatable :: nbrrank_p(:) ! Rank of neighboring processors (nodes)
integer,public,save,allocatable :: ranknbr_p(:) ! Mapping from MPI rank to neighbor index (nodes)
! integer,public,save :: nnbr_s ! Number of neighboring processors (sides); share with nodes (nnbr_p)
! integer,public,save,allocatable :: nbrrank_s(:) ! Rank of neighboring processors (sides)
! integer,public,save,allocatable :: ranknbr_s(:) ! Mapping from MPI rank to neighbor index (sides)
integer,public,save :: nnbr_2t ! Number of neighboring processors (2-tier elements)
integer,public,save,allocatable :: nbrrank_2t(:) ! Rank of neighboring processors (2-tier elements)
integer,public,save,allocatable :: ranknbr_2t(:) ! Mapping from MPI rank to neighbor index (2-tierelements)
!weno>
integer,public,save :: nnbr_s3
integer,public,save,allocatable :: nbrrank_s3(:) ! Rank of neighboring processors (elements)
integer,public,save,allocatable :: ranknbr_s3(:) ! Mapping from MPI rank to neighbor index (elements)
!<weno
!-----------------------------------------------------------------------------
! Private data
!-----------------------------------------------------------------------------
integer,save :: mnesend ! Max number of elements to send to a nbr
integer,save,allocatable :: nesend(:) ! Number of elements to send to each nbr
integer,save,allocatable :: iesend(:,:) ! Local index of send elements
integer,save :: mnerecv ! Max number of elements to receive from a nbr
integer,save,allocatable :: nerecv(:) ! Number of elements to receive from each nbr
integer,save,allocatable :: ierecv(:,:) ! Local index of recv elements
integer,save :: mnpsend ! Max number of nodes to send to a nbr
integer,save,allocatable :: npsend(:) ! Number of nodes to send to each nbr
integer,save,allocatable :: ipsend(:,:) ! Local index of send nodes
integer,save :: mnprecv ! Max number of nodes to receive from a nbr
integer,save,allocatable :: nprecv(:) ! Number of nodes to receive from each nbr
integer,save,allocatable :: iprecv(:,:) ! Local index of recv nodes
integer,save :: mnssend ! Max number of sides to send to a nbr
integer,save,allocatable :: nssend(:) ! Number of sides to send to each nbr
integer,save,allocatable :: issend(:,:) ! Local index of send sides
integer,save :: mnsrecv ! Max number of sides to receive from a nbr
integer,save,allocatable :: nsrecv(:) ! Number of sides to receive from each nbr
integer,save,allocatable :: isrecv(:,:) ! Local index of recv sides
!weno>
integer,save :: mnssend3 ! Max number of sides to send to a nbr (weno)
integer,save,allocatable :: nssend3(:) ! Number of sides to send to each nbr (weno) (weno)
integer,save,allocatable :: issend3(:,:) ! Local index of send sides (weno)
integer,save :: mnsrecv3 ! Max number of sides to receive from a nbr
integer,save,allocatable :: nsrecv3(:) ! Number of sides to receive from each nbr
integer,save,allocatable :: isrecv3(:,:) ! Local index of recv sides
!<weno
integer,save :: mnesend_2t ! Max number of 2-tier elements to send to a nbr
integer,save,allocatable :: nesend_2t(:) ! Number of 2-tier elements to send to each nbr
integer,save,allocatable :: iesend_2t(:,:) ! Local index of send 2-tier elements
integer,save :: mnerecv_2t ! Max number of 2-tier elements to receive from a nbr
integer,save,allocatable :: nerecv_2t(:) ! Number of 2-tier elements to receive from each nbr
integer,save,allocatable :: ierecv_2t(:,:) ! Local index of 2-tier recv elements
integer,save,allocatable :: e2dsend_type(:) ! 2D element send MPI datatype
integer,save,allocatable :: e2dsend_rqst(:) ! 2D element send request handles
integer,save,allocatable :: e2dsend_stat(:,:) ! 2D element send status handles
integer,save,allocatable :: e2drecv_type(:) ! 2D element recv MPI datatype
integer,save,allocatable :: e2drecv_rqst(:) ! 2D element recv request handles
integer,save,allocatable :: e2drecv_stat(:,:) ! 2D element recv status handles
integer,save,allocatable :: e2disend_type(:) ! 2D element send MPI datatype (integer)
integer,save,allocatable :: e2disend_rqst(:) ! 2D element send request handles (integer)
integer,save,allocatable :: e2disend_stat(:,:) ! 2D element send status handles (integer)
integer,save,allocatable :: e2direcv_type(:) ! 2D element recv MPI datatype (integer)
integer,save,allocatable :: e2direcv_rqst(:) ! 2D element recv request handles (integer)
integer,save,allocatable :: e2direcv_stat(:,:) ! 2D element recv status handles (integer)
integer,save,allocatable :: e2di_2t_send_type(:) ! 2D 2-tier element send MPI datatype (integer)
integer,save,allocatable :: e2di_2t_send_rqst(:) ! 2D 2-tier element send request handles (integer)
integer,save,allocatable :: e2di_2t_send_stat(:,:) ! 2D 2-tier element send status handles (integer)
integer,save,allocatable :: e2di_2t_recv_type(:) ! 2D 2-tier element recv MPI datatype (integer)
integer,save,allocatable :: e2di_2t_recv_rqst(:) ! 2D 2-tier element recv request handles (integer)
integer,save,allocatable :: e2di_2t_recv_stat(:,:) ! 2D 2-tier element recv status handles (integer)
integer,save,allocatable :: e3dwsend_type(:) ! 3D-whole-level element send MPI datatype
integer,save,allocatable :: e3dwsend_rqst(:) ! 3D-whole-level element send request handles
integer,save,allocatable :: e3dwsend_stat(:,:) ! 3D-whole-level element send status handles
integer,save,allocatable :: e3dwrecv_type(:) ! 3D-whole-level element recv MPI datatype
integer,save,allocatable :: e3dwrecv_rqst(:) ! 3D-whole-level element recv request handles
integer,save,allocatable :: e3dwrecv_stat(:,:) ! 3D-whole-level element recv status handles
integer,save,allocatable :: p2dsend_type(:) ! 2D node send MPI datatype
integer,save,allocatable :: p2dsend_rqst(:) ! 2D node send request handles
integer,save,allocatable :: p2dsend_stat(:,:) ! 2D node send status handles
integer,save,allocatable :: p2drecv_type(:) ! 2D node recv MPI datatype
integer,save,allocatable :: p2drecv_rqst(:) ! 2D node recv request handles
integer,save,allocatable :: p2drecv_stat(:,:) ! 2D node recv status handles
integer,save,allocatable :: p3dwsend_type(:) ! 3D-whole-level node send MPI datatype
integer,save,allocatable :: p3dwsend_rqst(:) ! 3D-whole-level node send request handles
integer,save,allocatable :: p3dwsend_stat(:,:) ! 3D-whole-level node send status handles
integer,save,allocatable :: p3dwrecv_type(:) ! 3D-whole-level node recv MPI datatype
integer,save,allocatable :: p3dwrecv_rqst(:) ! 3D-whole-level node recv request handles
integer,save,allocatable :: p3dwrecv_stat(:,:) ! 3D-whole-level node recv status handles
integer,save,allocatable :: p2disend_type(:) ! 2D node send MPI datatype (integer)
integer,save,allocatable :: p2disend_rqst(:) ! 2D node send request handles (integer)
integer,save,allocatable :: p2disend_stat(:,:) ! 2D node send status handles (integer)
integer,save,allocatable :: p2direcv_type(:) ! 2D node recv MPI datatype (integer)
integer,save,allocatable :: p2direcv_rqst(:) ! 2D node recv request handles (integer)
integer,save,allocatable :: p2direcv_stat(:,:) ! 2D node recv status handles (integer)
integer,save,allocatable :: p2d_9_send_type(:) ! 2Dx9 node send MPI datatype
integer,save,allocatable :: p2d_9_send_rqst(:) ! 2Dx9 node send request handles
integer,save,allocatable :: p2d_9_send_stat(:,:) ! 2Dx9 node send status handles
integer,save,allocatable :: p2d_9_recv_type(:) ! 2Dx9 node recv MPI datatype
integer,save,allocatable :: p2d_9_recv_rqst(:) ! 2Dx9 node recv request handles
integer,save,allocatable :: p2d_9_recv_stat(:,:) ! 2Dx9 node recv status handles
integer,save,allocatable :: s2dsend_type(:) ! 2D side send MPI datatype
integer,save,allocatable :: s2dsend_rqst(:) ! 2D side send request handles
integer,save,allocatable :: s2dsend_stat(:,:) ! 2D side send status handles
integer,save,allocatable :: s2drecv_type(:) ! 2D side recv MPI datatype
integer,save,allocatable :: s2drecv_rqst(:) ! 2D side recv request handles
integer,save,allocatable :: s2drecv_stat(:,:) ! 2D side recv status handles
integer,save,allocatable :: s2d_9_send_type(:) ! 2Dx9 side send MPI datatype
integer,save,allocatable :: s2d_9_send_rqst(:)
integer,save,allocatable :: s2d_9_send_stat(:,:)
integer,save,allocatable :: s2d_9_recv_type(:)
integer,save,allocatable :: s2d_9_recv_rqst(:)
integer,save,allocatable :: s2d_9_recv_stat(:,:)
integer,save,allocatable :: s3dwsend_type(:) ! 3D-whole-level side send MPI datatype
integer,save,allocatable :: s3dwsend_rqst(:) ! 3D-whole-level side send request handles
integer,save,allocatable :: s3dwsend_stat(:,:) ! 3D-whole-level side send status handles
integer,save,allocatable :: s3dwrecv_type(:) ! 3D-whole-level side recv MPI datatype
integer,save,allocatable :: s3dwrecv_rqst(:) ! 3D-whole-level side recv request handles
integer,save,allocatable :: s3dwrecv_stat(:,:) ! 3D-whole-level side recv status handles
integer,save,allocatable :: s2disend_type(:) ! 2D side send MPI datatype (integer)
integer,save,allocatable :: s2disend_rqst(:)
integer,save,allocatable :: s2disend_stat(:,:)
integer,save,allocatable :: s2direcv_type(:)
integer,save,allocatable :: s2direcv_rqst(:)
integer,save,allocatable :: s2direcv_stat(:,:)
! Following are arrays (:,:,:) exchange types
integer,save,allocatable :: s3d_5_send_type(:) ! 3Dx5 side send MPI datatype
integer,save,allocatable :: s3d_5_send_rqst(:) ! 3Dx5 side send request handles
integer,save,allocatable :: s3d_5_send_stat(:,:) ! 3Dx5 side send status handles
integer,save,allocatable :: s3d_5_recv_type(:) ! 3Dx5 side recv MPI datatype
integer,save,allocatable :: s3d_5_recv_rqst(:) ! 3Dx5 side recv request handles
integer,save,allocatable :: s3d_5_recv_stat(:,:) ! 3Dx5 side recv status handles
integer,save,allocatable :: s3d_4_send_type(:) ! 3Dx4 side send MPI datatype
integer,save,allocatable :: s3d_4_send_rqst(:) ! 3Dx4 side send request handles
integer,save,allocatable :: s3d_4_send_stat(:,:) ! 3Dx4 side send status handles
integer,save,allocatable :: s3d_4_recv_type(:) ! 3Dx4 side recv MPI datatype
integer,save,allocatable :: s3d_4_recv_rqst(:) ! 3Dx4 side recv request handles
integer,save,allocatable :: s3d_4_recv_stat(:,:) ! 3Dx4 side recv status handles
integer,save,allocatable :: s3d_2_send_type(:) ! 3Dx2 side send MPI datatype
integer,save,allocatable :: s3d_2_send_rqst(:)
integer,save,allocatable :: s3d_2_send_stat(:,:)
integer,save,allocatable :: s3d_2_recv_type(:)
integer,save,allocatable :: s3d_2_recv_rqst(:)
integer,save,allocatable :: s3d_2_recv_stat(:,:)
integer,save,allocatable :: s3d_tr2_send_type(:) ! 3Dx2 side send MPI datatype
integer,save,allocatable :: s3d_tr2_send_rqst(:)
integer,save,allocatable :: s3d_tr2_send_stat(:,:)
integer,save,allocatable :: s3d_tr2_recv_type(:)
integer,save,allocatable :: s3d_tr2_recv_rqst(:)
integer,save,allocatable :: s3d_tr2_recv_stat(:,:)
!weno>
integer,save,allocatable :: s3d_tr3_send_type(:) ! 3Dx2 side send MPI datatype
integer,save,allocatable :: s3d_tr3_send_rqst(:)
integer,save,allocatable :: s3d_tr3_send_stat(:,:)
integer,save,allocatable :: s3d_tr3_recv_type(:)
integer,save,allocatable :: s3d_tr3_recv_rqst(:)
integer,save,allocatable :: s3d_tr3_recv_stat(:,:)
!<weno
integer,save,allocatable :: p3d_2_send_type(:) ! 3Dx2 node send MPI datatype
integer,save,allocatable :: p3d_2_send_rqst(:)
integer,save,allocatable :: p3d_2_send_stat(:,:)
integer,save,allocatable :: p3d_2_recv_type(:)
integer,save,allocatable :: p3d_2_recv_rqst(:)
integer,save,allocatable :: p3d_2_recv_stat(:,:)
integer,save,allocatable :: p3d_3_send_type(:) ! 3Dx3 node send MPI datatype
integer,save,allocatable :: p3d_3_send_rqst(:)
integer,save,allocatable :: p3d_3_send_stat(:,:)
integer,save,allocatable :: p3d_3_recv_type(:)
integer,save,allocatable :: p3d_3_recv_rqst(:)
integer,save,allocatable :: p3d_3_recv_stat(:,:)
integer,save,allocatable :: p3d_4_send_type(:) ! 3Dx4 node send MPI datatype
integer,save,allocatable :: p3d_4_send_rqst(:)
integer,save,allocatable :: p3d_4_send_stat(:,:)
integer,save,allocatable :: p3d_4_recv_type(:)
integer,save,allocatable :: p3d_4_recv_rqst(:)
integer,save,allocatable :: p3d_4_recv_stat(:,:)
integer,save,allocatable :: p3d_tr_send_type(:) ! 3D x ntracers node send MPI datatype for tracers
integer,save,allocatable :: p3d_tr_send_rqst(:)
integer,save,allocatable :: p3d_tr_send_stat(:,:)
integer,save,allocatable :: p3d_tr_recv_type(:)
integer,save,allocatable :: p3d_tr_recv_rqst(:)
integer,save,allocatable :: p3d_tr_recv_stat(:,:)
integer,save,allocatable :: p4d_wwm_send_type(:) ! (msc2,mdc2,npa) node send MPI datatype for tracers
integer,save,allocatable :: p4d_wwm_send_rqst(:)
integer,save,allocatable :: p4d_wwm_send_stat(:,:)
integer,save,allocatable :: p4d_wwm_recv_type(:)
integer,save,allocatable :: p4d_wwm_recv_rqst(:)
integer,save,allocatable :: p4d_wwm_recv_stat(:,:)
integer,save,allocatable :: p3d_wwm_send_type(:) ! directional spectra node send MPI datatype
integer,save,allocatable :: p3d_wwm_send_rqst(:) ! directional spectra node send request handles
integer,save,allocatable :: p3d_wwm_send_stat(:,:) ! directional spectra node send status handles
integer,save,allocatable :: p3d_wwm_recv_type(:) ! directional spectra node recv MPI datatype
integer,save,allocatable :: p3d_wwm_recv_rqst(:) ! directional spectra node recv request handles
integer,save,allocatable :: p3d_wwm_recv_stat(:,:) ! directional spectra node recv status handles
integer,save,allocatable :: e3d_2_send_type(:) ! 3Dx2 element send MPI datatype
integer,save,allocatable :: e3d_2_send_rqst(:)
integer,save,allocatable :: e3d_2_send_stat(:,:)
integer,save,allocatable :: e3d_2_recv_type(:)
integer,save,allocatable :: e3d_2_recv_rqst(:)
integer,save,allocatable :: e3d_2_recv_stat(:,:)
integer,save,allocatable :: e3d_tr_send_type(:) ! Tracer transport element send MPI datatype
integer,save,allocatable :: e3d_tr_send_rqst(:)
integer,save,allocatable :: e3d_tr_send_stat(:,:)
integer,save,allocatable :: e3d_tr_recv_type(:)
integer,save,allocatable :: e3d_tr_recv_rqst(:)
integer,save,allocatable :: e3d_tr_recv_stat(:,:)
integer,save,allocatable :: e3d_tr2_send_type(:) ! Tracer transport element send MPI datatype
integer,save,allocatable :: e3d_tr2_send_rqst(:)
integer,save,allocatable :: e3d_tr2_send_stat(:,:)
integer,save,allocatable :: e3d_tr2_recv_type(:)
integer,save,allocatable :: e3d_tr2_recv_rqst(:)
integer,save,allocatable :: e3d_tr2_recv_stat(:,:)
integer,save,allocatable :: e3d_2t_tr_send_type(:) ! Tracer transport 2-tier element send MPI datatype
integer,save,allocatable :: e3d_2t_tr_send_rqst(:)
integer,save,allocatable :: e3d_2t_tr_send_stat(:,:)
integer,save,allocatable :: e3d_2t_tr_recv_type(:)
integer,save,allocatable :: e3d_2t_tr_recv_rqst(:)
integer,save,allocatable :: e3d_2t_tr_recv_stat(:,:)
! Following are 4D arrays (:,:,:,:) exchange types
!-----------------------------------------------------------------------------
! Public methods
!-----------------------------------------------------------------------------
public :: parallel_init ! Initialize parallel environment
public :: parallel_finalize ! Finalize parallel environment
public :: parallel_abort ! Abort parallel environment
public :: parallel_barrier ! Synchronize all tasks
public :: parallel_rrsync ! Round-Robin Synchronization
public :: msgp_tables ! Construct message-passing tables for subdomains
public :: msgp_init ! Initialize MPI datatypes for ghost exchange
public :: exchange_e2d ! 2D ghost element exchange
public :: exchange_e2di ! 2D ghost element exchange (integer)
public :: exchange_e3dw ! 3D-whole-level ghost element exchange
public :: exchange_e3d_2 ! ghost element exchange of type (2,nvrt,nm) where nm>=nea
public :: exchange_e3d_tr2 ! Tracer transport ghost element exchange of type (ntracers,nvrt,nm) where nm>=nea
public :: exchange_e2di_2t ! 2-tier ghost elem. exchange of type (nm) where nm>=nea2
public :: exchange_e3d_2t_tr ! 2-tier ghost elem. exchange of type (ntracers,nvrt,nm) where nm>=nea2
public :: exchange_p2d ! 2D ghost node exchange
public :: exchange_p3dw ! 3D-whole-level ghost node exchange
public :: exchange_p2di ! 2D ghost node exchange (integer)
public :: exchange_p2d_9 ! 2Dx9 ghost node exchange
public :: exchange_p3d_2 ! 3Dx2 ghost node exchange of type (2,nvrt,nm) where nm>=npa
public :: exchange_p3d_3 ! 3Dx3 ghost node exchange of type (3,nvrt,nm) where nm>=npa
public :: exchange_p3d_4 ! 3Dx4 ghost node exchange of type (4,nvrt,nm) where nm>=npa
public :: exchange_p3d_tr ! 3D x ntracers ghost node exchange of type (ntracers,nvrt,nm) where nm>=npa
#ifdef USE_WWM
public :: exchange_p4d_wwm ! ghost node exchange of type (msc2,mdc2,nm) where nm>=npa
public :: exchange_p3d_wwm ! ghost node exchange of type (mdc2,nm) where nm>=npa
#endif
public :: exchange_s2d ! 2D ghost side exchange
public :: exchange_s2d_9 ! 2Dx9 ghost side exchange of type (9,nm) where nm>=nsa
public :: exchange_s2di ! 2D ghost side exchange (integer)
public :: exchange_s3dw ! 3D-whole-level ghost side exchange
public :: exchange_s3d_5 ! 3Dx5 ghost side exchange of type (5,nvrt,nm) where nm>=nsa
public :: exchange_s3d_4 ! 3Dx4 ghost side exchange of type (4,nvrt,nm) where nm>=nsa
public :: exchange_s3d_2 ! 3Dx2 ghost side exchange of type (2,nvrt,nm) where nm>=nsa
public :: exchange_s3d_tr2 ! ghost side exchange of type (ntracers,nvrt,nm) where nm>=nsa
!weno>
public :: exchange_s3d_tr3 ! interface side exchange
!<weno
contains
subroutine parallel_init(communicator)
implicit none
integer, optional :: communicator
integer :: comm2,nproc3,myrank3,nproc_compute
if (present(communicator)) then
! Expect external call to mpi_init,
! use communicator as provided by the interface
call mpi_comm_dup(communicator,comm_schism,ierr)
else
! Initialize MPI
call mpi_init(ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr)
! Duplicate communication space to isolate ELCIRC communication
call mpi_comm_dup(MPI_COMM_WORLD,comm_schism,ierr)
endif
if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr)
! Get number of processors
call mpi_comm_size(comm_schism,nproc_schism,ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr)
! Get rank
call mpi_comm_rank(comm_schism,myrank_schism,ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr)
nproc_compute=nproc_schism-nscribes
if(myrank_schism<nproc_schism-nscribes) then !compute ranks
task_id=1
else !IO ranks
task_id=2
endif
!Use original rank as key to order the new ranks
CALL MPI_Comm_split(comm_schism,task_id,myrank_schism,comm2,ierr)
CALL MPI_Comm_size(comm2, nproc3, ierr)
CALL MPI_Comm_rank(comm2, myrank3,ierr)
if(task_id==1) then !compute
comm=comm2
nproc=nproc3
myrank=myrank3
! print*, 'Compute:',myrank_schism,nproc_schism,myrank,nproc,nproc_compute,nscribes,task_id
else !I/O scribes
comm_scribe=comm2
nproc_scribe=nproc3
myrank_scribe=myrank3
! print*, 'Scribes:',myrank_schism,nproc_schism,myrank3,nproc3,nproc_compute,nscribes,task_id
endif
end subroutine parallel_init
subroutine parallel_finalize
implicit none
call mpi_finalize(ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr)
end subroutine parallel_finalize
subroutine parallel_abort(string,error)
implicit none
character(*),optional,intent(in) :: string !string to print
integer,optional,intent(in) :: error !mpi errorcode
integer :: ierror,i
logical :: lopen
integer :: sl
character(80) :: s
inquire(11,opened=lopen)
if(present(string)) then
write(*,'(i4,2a)') myrank,': ABORT: ',string
if(lopen) write(11,'(i4,2a)') myrank,': ABORT: ',string
endif
if(present(error)) then
if(error/=MPI_SUCCESS) then
call mpi_error_string(error,s,sl,ierror)
write(*,'(i4,2a)') myrank,': MPI ERROR: ',s
if(lopen) write(11,'(i4,2a)') myrank,': MPI ERROR: ',s
endif
do i=1,500; inquire(i,opened=lopen); if(lopen) close(i); enddo;
call mpi_abort(comm_schism,error,ierror)
else
do i=1,500; inquire(i,opened=lopen); if(lopen) close(i); enddo;
call mpi_abort(comm_schism,0,ierror)
endif
end subroutine parallel_abort
subroutine parallel_barrier
implicit none
call mpi_barrier(comm,ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr)
end subroutine parallel_barrier
subroutine parallel_rrsync(istep)
!-------------------------------------------------------------------------------
! Performs multi-step round-robin synchronization of tasks starting with rank 0.
! Initial call is with istep=1. Subsequent steps are with istep>1. Final step
! is called with istep=-1*(istep of previous call). Here is the structure for
! a set of N compute blocks that require round-robin sychronization:
!
! call parallel_rrsync(1)
! [compute block 1]
! call parallel_rrsync(2)
! [compute block 2]
! ...
! ...
! call parallel_rrsync(N)
! [compute block N]
! call parallel_rrsync(-N)
!-------------------------------------------------------------------------------
implicit none
integer,intent(in) :: istep
integer :: ibgn,idsnd,itsnd,idrcv,itrcv
! Handle single processor case
if(nproc==1) return
! Step 1: Initial Round-Robin Synchronization
! Rank 0 continues while ranks>0 wait to receive start message to from previous rank
if(istep==1) then
! Rank 0 returns immediately
if(myrank==0) return
! Other ranks wait to recv start msg from previous rank
idrcv=myrank-1; itrcv=istep;
call mpi_recv(ibgn,1,itype,idrcv,itrcv,comm,istatus,ierr)
if(ierr/=MPI_SUCCESS) then
write(errmsg,*) 'PARALLEL_RRSYNC: recv start msg: ',idrcv,itrcv
call parallel_abort(errmsg,ierr)
endif
! Step > 1; Next step in Round-Robin Synchronization
elseif(istep>1) then
! Send start msg to next rank (cyclic)
if(myrank<nproc-1) then
idsnd=myrank+1; itsnd=istep-1; !next rank start previous step
else
idsnd=0; itsnd=istep; !rank 0 start current step
endif
call mpi_ssend(1,1,itype,idsnd,itsnd,comm,ierr)
if(ierr/=MPI_SUCCESS) then
write(errmsg,*) 'PARALLEL_RRSYNC: send start msg: ',idsnd,itsnd
call parallel_abort(errmsg,ierr)
endif
! Wait to receive start message to from previous rank
if(myrank>0) then
idrcv=myrank-1; itrcv=istep;
else
idrcv=nproc-1; itrcv=istep;
endif
call mpi_recv(ibgn,1,itype,idrcv,itrcv,comm,istatus,ierr)
if(ierr/=MPI_SUCCESS) then
write(errmsg,*) 'PARALLEL_RRSYNC: recv start msg: ',idrcv,itrcv
call parallel_abort(errmsg,ierr)
endif
! Step < 0; Final step in Round-Robin Synchronization
elseif(istep<0) then
! If not last rank then send start msg to next rank
if(myrank<nproc-1) then
idsnd=myrank+1; itsnd=abs(istep);
call mpi_ssend(1,1,itype,idsnd,itsnd,comm,ierr)
if(ierr/=MPI_SUCCESS) then
write(errmsg,*) 'PARALLEL_RRSYNC: send start msg: ',idsnd,itsnd
call parallel_abort(errmsg,ierr)
endif
endif
! Wait here for all ranks to finish
! (this prevents inadvertant overlap of rrsync sets)
call parallel_barrier
endif
end subroutine parallel_rrsync
subroutine msgp_tables
!-------------------------------------------------------------------------------
! Construct message-passing tables for elements, nodes & sides
!
! Requires completed partition and aquisition of horizontal and vertical grid
!-------------------------------------------------------------------------------
implicit none
integer :: i,j,k,l,ie,ip,isd,irank,stat,iegb,itmp
type(llist_type),pointer :: nd,sd
logical,allocatable :: nbr(:),nbr_p(:),nbr_s3(:)
integer,allocatable :: iegrecv(:,:),iegsend(:,:)
integer,allocatable :: iegrecv_2t(:,:),iegsend_2t(:,:)
integer,allocatable :: ipgrecv(:,:),ipgsend(:,:)
integer,allocatable :: isgrecv(:,:),isgsend(:,:)
!weno>
integer,allocatable :: isgrecv3(:,:),isgsend3(:,:)
!<weno
integer,allocatable :: srqst(:),sstat(:,:)
integer,allocatable :: rrqst(:),rstat(:,:)
!-------------------------------------------------------------------------------
! Handle single processor case
if(nproc==1) return
#ifdef DEBUG
fdb='ctbl_000000'
lfdb=len_trim(fdb)
write(fdb(lfdb-5:lfdb),'(i6.6)') myrank
open(10,file=out_dir(1:len_out_dir)//fdb,status='unknown')
#endif
!-----------------------------------------------------------------------------
! Construct table of neighbors for elements
!-----------------------------------------------------------------------------
! Use rank association of ghost elements to identify neighboring processors
allocate(nbr(0:nproc-1),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nbr allocation failure')
nbr=.false.
do ie=ne+1,nea
nbr(iegrpv(ielg(ie)))=.true.
enddo
! Count neighbors
nnbr=0
do irank=0,nproc-1
if(nbr(irank)) nnbr=nnbr+1
enddo
! Build table of neighbors
allocate(nbrrank(nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nbrrank allocation failure')
allocate(ranknbr(0:nproc-1),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: ranknbr allocation failure')
nnbr=0
ranknbr=0
do irank=0,nproc-1
if(nbr(irank)) then
nnbr=nnbr+1
nbrrank(nnbr)=irank
ranknbr(irank)=nnbr
endif
enddo
! Finished with nbr
deallocate(nbr)
!-----------------------------------------------------------------------------
! Construct element message-passing tables
!-----------------------------------------------------------------------------
! Allocate and count number of recv ghost elements
allocate(nerecv(nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nerecv allocation failure')
nerecv=0
do ie=ne+1,nea
irank=iegrpv(ielg(ie))
! try not to use i in nerecv() (OK because nnbr>0)
do i=1,nnbr; if(irank==nbrrank(i)) exit; enddo;
nerecv(i)=nerecv(i)+1
enddo
! Compute maximum number of recv ghost elements
mnerecv=0
do i=1,nnbr
mnerecv=max(mnerecv,nerecv(i))
enddo
! Allocate and construct tables for recv elements
allocate(ierecv(mnerecv,nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: ierecv allocation failure')
allocate(iegrecv(mnerecv,nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: iegrecv allocation failure')
nerecv=0
do ie=ne+1,nea
irank=iegrpv(ielg(ie))
do i=1,nnbr; if(irank==nbrrank(i)) exit; enddo;
nerecv(i)=nerecv(i)+1
ierecv(nerecv(i),i)=ie !local index
iegrecv(nerecv(i),i)=ielg(ie) !global index
enddo
#ifdef DEBUG
write(10,'(a,i8)') 'Number of neighbors:',nnbr
write(10,'(a)') '##########################################################'
write(10,'(a)') 'Element Receive Table:'
do i=1,nnbr
write(10,'(a,3i8)') 'nbrindx,rank,nerecv: ',&
&ranknbr(nbrrank(i)),nbrrank(i),nerecv(i)
do j=1,nerecv(i)
write(10,'(t1,2i8)') ierecv(j,i),iegrecv(j,i)
enddo
enddo
write(10,'(a)') '##########################################################'
call parallel_barrier
#endif
! Allocate message-passing objects and flags
allocate(rrqst(nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: rrqst allocation failure')
allocate(rstat(MPI_STATUS_SIZE,nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: rstat allocation failure')
allocate(srqst(nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: srqst allocation failure')
allocate(sstat(MPI_STATUS_SIZE,nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: sstat allocation failure')
! Allocate element send count array
allocate(nesend(nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nesend allocation failure')
! Communicate ghost element counts with nbrs
! nerecv(i): # of ghost elements to be received from neighbor i to myrank
! nesend(i): # of ghost elements to be sent to neighbor i (from myrank)
! Communication involves all neighbors (and synchronized)
do i=1,nnbr
call mpi_irecv(nesend(i),1,itype,nbrrank(i),10,comm,rrqst(i),ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_irecv tag=10',ierr)
enddo
do i=1,nnbr
call mpi_isend(nerecv(i),1,itype,nbrrank(i),10,comm,srqst(i),ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_isend tag=10',ierr)
enddo
call mpi_waitall(nnbr,rrqst,rstat,ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_waitall rrqst tag=10',ierr)
call mpi_waitall(nnbr,srqst,sstat,ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_waitall srqst tag=10',ierr)
! Compute maximum number of send elements
mnesend=0
do i=1,nnbr
mnesend=max(mnesend,nesend(i))
enddo
! Allocate tables for send elements
allocate(iesend(mnesend,nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: iesend allocation failure')
allocate(iegsend(mnesend,nnbr),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: iegsend allocation failure')
! Communicate element send lists (global index) with nbrs
do i=1,nnbr
call mpi_irecv(iegsend(1,i),nesend(i),itype,nbrrank(i),11,comm,rrqst(i),ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_irecv tag=11',ierr)
enddo
do i=1,nnbr
! iegrecv(1,i) is the starting address, nerecv(i) is the count
call mpi_isend(iegrecv(1,i),nerecv(i),itype,nbrrank(i),11,comm,srqst(i),ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_isend tag=11',ierr)
enddo
call mpi_waitall(nnbr,rrqst,rstat,ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_waitall rrqst tag=11',ierr)
call mpi_waitall(nnbr,srqst,sstat,ierr)
if(ierr/=MPI_SUCCESS) &
call parallel_abort('msgp_tables: mpi_waitall srqst tag=11',ierr)
! Construct locally indexed element send table
do i=1,nnbr
do j=1,nesend(i)
if(iegl(iegsend(j,i))%rank/=myrank) call parallel_abort('send element not resident!')
iesend(j,i)=iegl(iegsend(j,i))%id !send element is resident
enddo
enddo
#ifdef DEBUG
write(10,'(a)') 'Element Send Table:'
do i=1,nnbr
write(10,'(a,3i8)') 'nbrindx,rank,nesend: ',&
&ranknbr(nbrrank(i)),nbrrank(i),nesend(i)
do j=1,nesend(i)
write(10,'(t1,2i8)') iesend(j,i),iegsend(j,i)
enddo
enddo
write(10,'(a)') '##########################################################'
call parallel_barrier
#endif
! Done with global indexed arrays -- deallocate
deallocate(iegsend)
deallocate(iegrecv)
!-----------------------------------------------------------------------------
! Construct node message-passing tables
!-----------------------------------------------------------------------------
! Neigbor table (excluding myrank itself)
! Neighbors from 2-layers into ghost zone in order to find the smallest rank
! for each ghost node (as the smallest rank may not be inside nnbr for elem)
allocate(nbr_p(0:nproc-1),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nbr allocation failure')
nbr_p=.false.
do ie=ne+1,nea
iegb=ielg(ie)
nbr_p(iegrpv(iegb))=.true.
do j=1,i34(ie) !nodes
itmp=elnode(j,ie) !nmgb(j,iegb)
do l=1,nne(itmp) !nnegb(itmp)
k=indel(l,itmp) !inegb(itmp,l)
if(k==0) then
call parallel_abort('msgp_tables: bomb (6)')
else if(k>0) then
k=ielg(k) !global index
else !k<0; outside
k=iabs(k)
endif !k
if(iegrpv(k)/=myrank) nbr_p(iegrpv(k))=.true.
enddo !l
enddo !j
enddo
! Count neighbors
nnbr_p=0
do irank=0,nproc-1
if(nbr_p(irank)) nnbr_p=nnbr_p+1
enddo
! Build table of neighbors
allocate(nbrrank_p(nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nbrrank_p allocation failure')
allocate(ranknbr_p(0:nproc-1),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: ranknbr_p allocation failure')
nnbr_p=0
ranknbr_p=0 !flag
do irank=0,nproc-1
if(nbr_p(irank)) then
nnbr_p=nnbr_p+1
nbrrank_p(nnbr_p)=irank
ranknbr_p(irank)=nnbr_p
endif
enddo
! Finished with nbr_p
deallocate(nbr_p)
! Allocate and count number of recv nodes
! nprecv(i): # of ghost nodes to be received from neighbor i to myrank
! npsend(i): # of ghost nodes to be sent to neighbor i (from myrank)
allocate(nprecv(nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: nprecv allocation failure')
nprecv=0
do ip=np+1,npa
nd=>ipgl(iplg(ip))%next
if(.not.associated(nd)) then !error: llist must have at least two entries
write(errmsg,*) 'comm_table: error1 in ipgl: ',myrank,ip,iplg(ip)
#ifdef DEBUG
close(10)
#endif
call parallel_abort(errmsg)
endif
! Look for the smallest rank
itmp=nproc !smallest rank
n01: do
if(nd%rank<itmp) itmp=nd%rank
nd=>nd%next
if(.not.associated(nd)) exit
enddo n01
if(itmp==nproc) call parallel_abort('Failed to find a rank')
j=0 !flag
do i=1,nnbr_p
if(nbrrank_p(i)==itmp) then
j=i
exit
endif
enddo !i
if(j==0) call parallel_abort('Failed to find a process')
nprecv(j)=nprecv(j)+1
enddo !ip=np+1,npa
! Interface nodes: use the value from the smallest rank to ensure consistency
! among all processes
do ip=1,np
nd=>ipgl(iplg(ip))%next
if(associated(nd)) then !interface nodes
if(nd%rank<myrank) then !nd%rank is the smallest rank
j=0 !flag
do i=1,nnbr_p
if(nd%rank==nbrrank_p(i)) then
j=i
exit
endif
enddo !i
if(j==0) call parallel_abort('Failed to find a process (2)')
nprecv(j)=nprecv(j)+1
endif
endif !interface nodes
enddo !ip=1,np
! Compute maximum number of recv nodes
mnprecv=0
do i=1,nnbr_p
mnprecv=max(mnprecv,nprecv(i))
enddo
! Allocate and construct table for recv nodes
allocate(iprecv(mnprecv,nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: iprecv allocation failure')
allocate(ipgrecv(mnprecv,nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: ipgrecv allocation failure')
nprecv=0
do ip=np+1,npa
nd=>ipgl(iplg(ip))%next
itmp=nproc
n02: do
if(nd%rank<itmp) itmp=nd%rank
nd=>nd%next
if(.not.associated(nd)) exit
enddo n02
do i=1,nnbr_p; if(itmp==nbrrank_p(i)) exit; enddo;
nprecv(i)=nprecv(i)+1
iprecv(nprecv(i),i)=ip !local index
ipgrecv(nprecv(i),i)=iplg(ip) !global index
enddo !ip
do ip=1,np
nd=>ipgl(iplg(ip))%next
if(associated(nd)) then !interface nodes
if(nd%rank<myrank) then !nd%rank is the smallest rank
j=0 !flag
do i=1,nnbr_p
if(nd%rank==nbrrank_p(i)) then
j=i
exit
endif
enddo !i
if(j==0) call parallel_abort('Failed to find a process (3)')
nprecv(j)=nprecv(j)+1
iprecv(nprecv(j),j)=ip !local index
ipgrecv(nprecv(j),j)=iplg(ip) !global index
endif
endif !interface nodes
enddo !ip=1,np
#ifdef DEBUG
write(10,'(a)') 'Node Receive Table:'
do i=1,nnbr_p
write(10,'(a,3i8)') 'nbrindx,rank,nprecv: ',&
&ranknbr_p(nbrrank_p(i)),nbrrank_p(i),nprecv(i)
if(nprecv(i)==0) then
write(10,*) 'Zero recv'
! write(errmsg,*) 'MSGP: Zero recv; see ctb*'
! call parallel_abort(errmsg)
endif
do j=1,nprecv(i)
write(10,'(t1,2i8)') iprecv(j,i),ipgrecv(j,i)
enddo
enddo
write(10,'(a)') '##########################################################'
call parallel_barrier
#endif
! Allocate node send count array
allocate(npsend(nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: npsend allocation failure')
deallocate(rrqst,rstat,srqst,sstat)
allocate(rrqst(nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: rrqst allocation failure (2)')
allocate(rstat(MPI_STATUS_SIZE,nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: rstat allocation failure (2)')
allocate(srqst(nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: srqst allocation failure (2)')
allocate(sstat(MPI_STATUS_SIZE,nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: sstat allocation failure (2)')
! Communicate exchange node counts with nbrs
do i=1,nnbr_p
call mpi_irecv(npsend(i),1,itype,nbrrank_p(i),20,comm,rrqst(i),ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_irecv tag=20',ierr)
enddo
do i=1,nnbr_p
call mpi_isend(nprecv(i),1,itype,nbrrank_p(i),20,comm,srqst(i),ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_isend tag=20',ierr)
enddo
call mpi_waitall(nnbr_p,rrqst,rstat,ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_waitall rrqst tag=20',ierr)
call mpi_waitall(nnbr_p,srqst,sstat,ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_waitall srqst tag=20',ierr)
! Compute maximum number of send nodes
mnpsend=0
do i=1,nnbr_p
mnpsend=max(mnpsend,npsend(i))
enddo
! Allocate tables for send nodes
allocate(ipsend(mnpsend,nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: ipsend allocation failure')
allocate(ipgsend(mnpsend,nnbr_p),stat=stat)
if(stat/=0) call parallel_abort('msgp_tables: ipgsend allocation failure')
! Communicate node send lists (global index) with nbrs
do i=1,nnbr_p
if(npsend(i)/=0) then
call mpi_irecv(ipgsend(1,i),npsend(i),itype,nbrrank_p(i),21,comm,rrqst(i),ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_irecv tag=21',ierr)
else
rrqst(i)=MPI_REQUEST_NULL
endif
enddo
do i=1,nnbr_p
if(nprecv(i)/=0) then
call mpi_isend(ipgrecv(1,i),nprecv(i),itype,nbrrank_p(i),21,comm,srqst(i),ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_isend tag=21',ierr)
else
srqst(i)=MPI_REQUEST_NULL
endif
enddo
call mpi_waitall(nnbr_p,rrqst,rstat,ierr)
if(ierr/=MPI_SUCCESS) call parallel_abort('msgp_tables: mpi_waitall rrqst tag=21',ierr)