93 #ifndef __NO_16BYTE_REALS 139 integer(ip_i4_p),
intent(in) :: rcode
140 character(*),
intent(in) :: string
143 character(*),
parameter :: subname =
'(oasis_mpi_chkerr)' 144 character(MPI_MAX_ERROR_STRING) :: lstring
145 integer(ip_i4_p) :: len
146 integer(ip_i4_p) :: ierr
155 if (rcode /= mpi_success)
then 156 call mpi_error_string(rcode,lstring,len,ierr)
174 integer(ip_i4_p),
intent(in) :: lvec
175 integer(ip_i4_p),
intent(in) :: pid
176 integer(ip_i4_p),
intent(in) :: tag
177 integer(ip_i4_p),
intent(in) :: comm
178 character(*),
optional,
intent(in) :: string
181 character(*),
parameter :: subname =
'(oasis_mpi_sendi0)' 182 integer(ip_i4_p) :: lsize
183 integer(ip_i4_p) :: ierr
193 call mpi_send(lvec,lsize,mpi_integer,pid,tag,comm,ierr)
194 if (
present(string))
then 214 integer(ip_i4_p),
intent(in) :: lvec(:)
215 integer(ip_i4_p),
intent(in) :: pid
216 integer(ip_i4_p),
intent(in) :: tag
217 integer(ip_i4_p),
intent(in) :: comm
218 character(*),
optional,
intent(in) :: string
221 character(*),
parameter :: subname =
'(oasis_mpi_sendi1)' 222 integer(ip_i4_p) :: lsize
223 integer(ip_i4_p) :: ierr
233 call mpi_send(lvec,lsize,mpi_integer,pid,tag,comm,ierr)
234 if (
present(string))
then 254 real(ip_double_p),
intent(in) :: lvec
255 integer(ip_i4_p),
intent(in) :: pid
256 integer(ip_i4_p),
intent(in) :: tag
257 integer(ip_i4_p),
intent(in) :: comm
258 character(*),
optional,
intent(in) :: string
261 character(*),
parameter :: subname =
'(oasis_mpi_sendr0)' 262 integer(ip_i4_p) :: lsize
263 integer(ip_i4_p) :: ierr
273 call mpi_send(lvec,lsize,mpi_real8,pid,tag,comm,ierr)
274 if (
present(string))
then 294 real(ip_double_p),
intent(in) :: lvec(:)
295 integer(ip_i4_p),
intent(in) :: pid
296 integer(ip_i4_p),
intent(in) :: tag
297 integer(ip_i4_p),
intent(in) :: comm
298 character(*),
optional,
intent(in) :: string
301 character(*),
parameter :: subname =
'(oasis_mpi_sendr1)' 302 integer(ip_i4_p) :: lsize
303 integer(ip_i4_p) :: ierr
313 call mpi_send(lvec,lsize,mpi_real8,pid,tag,comm,ierr)
314 if (
present(string))
then 334 real(ip_double_p),
intent(in) :: array(:,:,:)
335 integer(ip_i4_p),
intent(in) :: pid
336 integer(ip_i4_p),
intent(in) :: tag
337 integer(ip_i4_p),
intent(in) :: comm
338 character(*),
optional,
intent(in) :: string
341 character(*),
parameter :: subname =
'(oasis_mpi_sendr3)' 342 integer(ip_i4_p) :: lsize
343 integer(ip_i4_p) :: ierr
353 call mpi_send(array,lsize,mpi_real8,pid,tag,comm,ierr)
354 if (
present(string))
then 374 integer(ip_i4_p),
intent(out):: lvec
375 integer(ip_i4_p),
intent(in) :: pid
376 integer(ip_i4_p),
intent(in) :: tag
377 integer(ip_i4_p),
intent(in) :: comm
378 character(*),
optional,
intent(in) :: string
381 character(*),
parameter :: subname =
'(oasis_mpi_recvi0)' 382 integer(ip_i4_p) :: lsize
383 integer(ip_i4_p) :: status(mpi_status_size)
384 integer(ip_i4_p) :: ierr
394 call mpi_recv(lvec,lsize,mpi_integer,pid,tag,comm,status,ierr)
395 if (
present(string))
then 415 integer(ip_i4_p),
intent(out):: lvec(:)
416 integer(ip_i4_p),
intent(in) :: pid
417 integer(ip_i4_p),
intent(in) :: tag
418 integer(ip_i4_p),
intent(in) :: comm
419 character(*),
optional,
intent(in) :: string
422 character(*),
parameter :: subname =
'(oasis_mpi_recvi1)' 423 integer(ip_i4_p) :: lsize
424 integer(ip_i4_p) :: status(mpi_status_size)
425 integer(ip_i4_p) :: ierr
435 call mpi_recv(lvec,lsize,mpi_integer,pid,tag,comm,status,ierr)
436 if (
present(string))
then 456 real(ip_double_p),
intent(out):: lvec
457 integer(ip_i4_p),
intent(in) :: pid
458 integer(ip_i4_p),
intent(in) :: tag
459 integer(ip_i4_p),
intent(in) :: comm
460 character(*),
optional,
intent(in) :: string
463 character(*),
parameter :: subname =
'(oasis_mpi_recvr0)' 464 integer(ip_i4_p) :: lsize
465 integer(ip_i4_p) :: status(mpi_status_size)
466 integer(ip_i4_p) :: ierr
476 call mpi_recv(lvec,lsize,mpi_real8,pid,tag,comm,status,ierr)
477 if (
present(string))
then 497 real(ip_double_p),
intent(out):: lvec(:)
498 integer(ip_i4_p),
intent(in) :: pid
499 integer(ip_i4_p),
intent(in) :: tag
500 integer(ip_i4_p),
intent(in) :: comm
501 character(*),
optional,
intent(in) :: string
504 character(*),
parameter :: subname =
'(oasis_mpi_recvr1)' 505 integer(ip_i4_p) :: lsize
506 integer(ip_i4_p) :: status(mpi_status_size)
507 integer(ip_i4_p) :: ierr
517 call mpi_recv(lvec,lsize,mpi_real8,pid,tag,comm,status,ierr)
518 if (
present(string))
then 538 real(ip_double_p),
intent(out):: array(:,:,:)
539 integer(ip_i4_p),
intent(in) :: pid
540 integer(ip_i4_p),
intent(in) :: tag
541 integer(ip_i4_p),
intent(in) :: comm
542 character(*),
optional,
intent(in) :: string
545 character(*),
parameter :: subname =
'(oasis_mpi_recvr3)' 546 integer(ip_i4_p) :: lsize
547 integer(ip_i4_p) :: status(mpi_status_size)
548 integer(ip_i4_p) :: ierr
558 call mpi_recv(array,lsize,mpi_real8,pid,tag,comm,status,ierr)
559 if (
present(string))
then 579 integer(ip_i4_p),
intent(inout):: vec
580 integer(ip_i4_p),
intent(in) :: comm
581 character(*),
optional,
intent(in) :: string
582 integer(ip_i4_p),
optional,
intent(in) :: pebcast
585 character(*),
parameter :: subname =
'(oasis_mpi_bcasti0)' 586 integer(ip_i4_p) :: ierr
587 integer(ip_i4_p) :: lsize
588 integer(ip_i4_p) :: lpebcast
598 if (
present(pebcast)) lpebcast = pebcast
600 call mpi_bcast(vec,lsize,mpi_integer,lpebcast,comm,ierr)
601 if (
present(string))
then 621 logical,
intent(inout):: vec
622 integer(ip_i4_p),
intent(in) :: comm
623 character(*),
optional,
intent(in) :: string
624 integer(ip_i4_p),
optional,
intent(in) :: pebcast
627 character(*),
parameter :: subname =
'(oasis_mpi_bcastl0)' 628 integer(ip_i4_p) :: ierr
629 integer(ip_i4_p) :: lsize
630 integer(ip_i4_p) :: lpebcast
640 if (
present(pebcast)) lpebcast = pebcast
642 call mpi_bcast(vec,lsize,mpi_logical,lpebcast,comm,ierr)
643 if (
present(string))
then 663 character(len=*),
intent(inout):: vec
664 integer(ip_i4_p),
intent(in) :: comm
665 character(*),
optional,
intent(in) :: string
666 integer(ip_i4_p),
optional,
intent(in) :: pebcast
669 character(*),
parameter :: subname =
'(oasis_mpi_bcastc0)' 670 integer(ip_i4_p) :: ierr
671 integer(ip_i4_p) :: lsize
672 integer(ip_i4_p) :: lpebcast
682 if (
present(pebcast)) lpebcast = pebcast
684 call mpi_bcast(vec,lsize,mpi_character,lpebcast,comm,ierr)
685 if (
present(string))
then 705 character(len=*),
intent(inout):: vec(:)
706 integer(ip_i4_p),
intent(in) :: comm
707 character(*),
optional,
intent(in) :: string
708 integer(ip_i4_p),
optional,
intent(in) :: pebcast
711 character(*),
parameter :: subname =
'(oasis_mpi_bcastc1)' 712 integer(ip_i4_p) :: ierr
713 integer(ip_i4_p) :: lsize
714 integer(ip_i4_p) :: lpebcast
722 lsize =
size(vec)*len(vec)
724 if (
present(pebcast)) lpebcast = pebcast
726 call mpi_bcast(vec,lsize,mpi_character,lpebcast,comm,ierr)
727 if (
present(string))
then 747 real(ip_double_p),
intent(inout):: vec
748 integer(ip_i4_p),
intent(in) :: comm
749 character(*),
optional,
intent(in) :: string
750 integer(ip_i4_p),
optional,
intent(in) :: pebcast
753 character(*),
parameter :: subname =
'(oasis_mpi_bcastr0)' 754 integer(ip_i4_p) :: ierr
755 integer(ip_i4_p) :: lsize
756 integer(ip_i4_p) :: lpebcast
766 if (
present(pebcast)) lpebcast = pebcast
768 call mpi_bcast(vec,lsize,mpi_real8,lpebcast,comm,ierr)
769 if (
present(string))
then 789 integer(ip_i4_p),
intent(inout):: vec(:)
790 integer(ip_i4_p),
intent(in) :: comm
791 character(*),
optional,
intent(in) :: string
792 integer(ip_i4_p),
optional,
intent(in) :: pebcast
795 character(*),
parameter :: subname =
'(oasis_mpi_bcasti1)' 796 integer(ip_i4_p) :: ierr
797 integer(ip_i4_p) :: lsize
798 integer(ip_i4_p) :: lpebcast
808 if (
present(pebcast)) lpebcast = pebcast
810 call mpi_bcast(vec,lsize,mpi_integer,lpebcast,comm,ierr)
811 if (
present(string))
then 831 logical,
intent(inout):: vec(:)
832 integer(ip_i4_p),
intent(in) :: comm
833 character(*),
optional,
intent(in) :: string
834 integer(ip_i4_p),
optional,
intent(in) :: pebcast
837 character(*),
parameter :: subname =
'(oasis_mpi_bcastl1)' 838 integer(ip_i4_p) :: ierr
839 integer(ip_i4_p) :: lsize
840 integer(ip_i4_p) :: lpebcast
850 if (
present(pebcast)) lpebcast = pebcast
852 call mpi_bcast(vec,lsize,mpi_logical,lpebcast,comm,ierr)
853 if (
present(string))
then 873 real(ip_double_p),
intent(inout):: vec(:)
874 integer(ip_i4_p),
intent(in) :: comm
875 character(*),
optional,
intent(in) :: string
876 integer(ip_i4_p),
optional,
intent(in) :: pebcast
879 character(*),
parameter :: subname =
'(oasis_mpi_bcastr1)' 880 integer(ip_i4_p) :: ierr
881 integer(ip_i4_p) :: lsize
882 integer(ip_i4_p) :: lpebcast
892 if (
present(pebcast)) lpebcast = pebcast
894 call mpi_bcast(vec,lsize,mpi_real8,lpebcast,comm,ierr)
895 if (
present(string))
then 915 real(ip_double_p),
intent(inout):: arr(:,:)
916 integer(ip_i4_p),
intent(in) :: comm
917 character(*),
optional,
intent(in) :: string
918 integer(ip_i4_p),
optional,
intent(in) :: pebcast
921 integer(ip_i4_p) :: ierr
922 integer(ip_i4_p) :: lsize
923 integer(ip_i4_p) :: lpebcast
926 character(*),
parameter :: subname =
'(oasis_mpi_bcastr2)' 936 if (
present(pebcast)) lpebcast = pebcast
938 call mpi_bcast(arr,lsize,mpi_real8,lpebcast,comm,ierr)
939 if (
present(string))
then 959 integer,
intent(inout):: arr(:,:)
960 integer(ip_i4_p),
intent(in) :: comm
961 character(*),
optional,
intent(in) :: string
962 integer(ip_i4_p),
optional,
intent(in) :: pebcast
965 integer(ip_i4_p) :: ierr
966 integer(ip_i4_p) :: lsize
967 integer(ip_i4_p) :: lpebcast
970 character(*),
parameter :: subname =
'(oasis_mpi_bcasti2)' 980 if (
present(pebcast)) lpebcast = pebcast
982 call mpi_bcast(arr,lsize,mpi_integer,lpebcast,comm,ierr)
983 if (
present(string))
then 1003 real(ip_double_p),
intent(inout):: arr(:,:,:)
1004 integer(ip_i4_p),
intent(in) :: comm
1005 character(*),
optional,
intent(in) :: string
1006 integer(ip_i4_p),
optional,
intent(in) :: pebcast
1009 integer(ip_i4_p) :: ierr
1010 integer(ip_i4_p) :: lsize
1011 integer(ip_i4_p) :: lpebcast
1014 character(*),
parameter :: subname =
'(oasis_mpi_bcastr3)' 1024 if (
present(pebcast)) lpebcast = pebcast
1026 call mpi_bcast(arr,lsize,mpi_real8,lpebcast,comm,ierr)
1027 if (
present(string))
then 1052 integer(ip_i4_p),
intent(in) :: comm
1053 integer(ip_i4_p),
intent(in) :: rootid
1054 real(ip_double_p),
intent(in) :: locArr(:)
1055 real(ip_double_p),
pointer :: glob1DArr(:)
1056 integer(ip_i4_p),
pointer :: globSize(:)
1057 integer(ip_i4_p),
pointer :: displs(:)
1058 character(*),
optional,
intent(in):: string
1061 integer(ip_i4_p) :: npes
1062 integer(ip_i4_p) :: locSize
1063 integer(ip_i4_p),
pointer :: sendSize(:)
1064 integer(ip_i4_p) :: i
1065 integer(ip_i4_p) :: rank
1066 integer(ip_i4_p) :: nSize
1067 integer(ip_i4_p) :: ierr
1068 integer(ip_i4_p) :: nSiz1D
1069 integer(ip_i4_p) :: maxSize
1072 character(*),
parameter :: subname =
'(oasis_mpi_gathScatvInitr1)' 1080 locsize =
size(locarr)
1083 allocate( globsize(npes) )
1087 allocate( sendsize(npes) )
1090 call mpi_gather( locsize, 1, mpi_integer, globsize, sendsize, &
1091 mpi_integer, rootid, comm, ierr )
1092 if (
present(string))
then 1097 deallocate( sendsize )
1101 allocate( displs(npes) )
1103 if ( rootid /= rank )
then 1107 maxsize = maxval(globsize)
1109 nsiz1d = min(maxsize,globsize(1))
1111 nsize = min(maxsize,globsize(i-1))
1112 displs(i) = displs(i-1) + nsize
1113 nsiz1d = nsiz1d + min(maxsize,globsize(i))
1115 allocate( glob1darr(nsiz1d) )
1117 if ( rootid == rank )
then 1118 if ( nsiz1d /= sum(globsize) ) &
1119 call oasis_mpi_abort( subname//
" : Error, size of global array not right" )
1120 if ( any(displs < 0) .or. any(displs >= nsiz1d) ) &
1121 call oasis_mpi_abort( subname//
" : Error, displacement array not right" )
1122 if ( (displs(npes)+globsize(npes)) /= nsiz1d ) &
1123 call oasis_mpi_abort( subname//
" : Error, displacement array values too big" )
1146 real(ip_double_p),
intent(in) :: locArr(:)
1147 real(ip_double_p),
intent(inout) :: glob1DArr(:)
1148 integer(ip_i4_p),
intent(in) :: locSize
1149 integer(ip_i4_p),
intent(in) :: globSize(:)
1150 integer(ip_i4_p),
intent(in) :: displs(:)
1151 integer(ip_i4_p),
intent(in) :: rootid
1152 integer(ip_i4_p),
intent(in) :: comm
1153 character(*),
optional,
intent(in):: string
1156 integer(ip_i4_p) :: ierr
1159 character(*),
parameter :: subname =
'(oasis_mpi_gathervr1)' 1167 call mpi_gatherv( locarr, locsize, mpi_real8, glob1darr, globsize, displs, &
1168 mpi_real8, rootid, comm, ierr )
1169 if (
present(string))
then 1195 real(ip_double_p),
intent(out) :: locarr(:)
1196 real(ip_double_p),
intent(in) :: glob1Darr(:)
1197 integer(ip_i4_p),
intent(in) :: locSize
1198 integer(ip_i4_p),
intent(in) :: globSize(:)
1199 integer(ip_i4_p),
intent(in) :: displs(:)
1200 integer(ip_i4_p),
intent(in) :: rootid
1201 integer(ip_i4_p),
intent(in) :: comm
1202 character(*),
optional,
intent(in):: string
1205 integer(ip_i4_p) :: ierr
1208 character(*),
parameter :: subname =
'(oasis_mpi_scattervr1)' 1216 call mpi_scatterv( glob1darr, globsize, displs, mpi_real8, locarr, locsize, &
1217 mpi_real8, rootid, comm, ierr )
1218 if (
present(string))
then 1239 integer(ip_i4_p),
intent(in) :: lvec
1240 integer(ip_i4_p),
intent(out):: gvec
1241 integer(ip_i4_p),
intent(in) :: comm
1242 character(*),
optional,
intent(in) :: string
1243 logical,
optional,
intent(in) :: all
1246 character(*),
parameter :: subname =
'(oasis_mpi_sumi0)' 1248 character(len=256) :: lstring
1249 integer(ip_i4_p) :: reduce_type
1250 integer(ip_i4_p) :: lsize
1251 integer(ip_i4_p) :: gsize
1252 integer(ip_i4_p) :: ierr
1261 reduce_type = mpi_sum
1262 if (
present(all))
then 1267 if (
present(string))
then 1268 lstring = trim(subname)//
":"//trim(string)
1270 lstring = trim(subname)
1276 if (lsize /= gsize)
then 1277 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1281 call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
1284 call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
1305 integer(ip_i4_p),
intent(in) :: lvec(:)
1306 integer(ip_i4_p),
intent(out):: gvec(:)
1307 integer(ip_i4_p),
intent(in) :: comm
1308 character(*),
optional,
intent(in) :: string
1309 logical,
optional,
intent(in) :: all
1312 character(*),
parameter :: subname =
'(oasis_mpi_sumi1)' 1314 character(len=256) :: lstring
1315 integer(ip_i4_p) :: reduce_type
1316 integer(ip_i4_p) :: lsize
1317 integer(ip_i4_p) :: gsize
1318 integer(ip_i4_p) :: ierr
1327 reduce_type = mpi_sum
1328 if (
present(all))
then 1333 if (
present(string))
then 1334 lstring = trim(subname)//
":"//trim(string)
1336 lstring = trim(subname)
1342 if (lsize /= gsize)
then 1343 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1347 call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
1350 call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
1368 integer(ip_i8_p),
intent(in) :: lvec
1369 integer(ip_i8_p),
intent(out):: gvec
1370 integer(ip_i4_p),
intent(in) :: comm
1371 character(*),
optional,
intent(in) :: string
1372 logical,
optional,
intent(in) :: all
1375 character(*),
parameter :: subname =
'(oasis_mpi_sumb0)' 1377 character(len=256) :: lstring
1378 integer(ip_i4_p) :: reduce_type
1379 integer(ip_i4_p) :: lsize
1380 integer(ip_i4_p) :: gsize
1381 integer(ip_i4_p) :: ierr
1390 reduce_type = mpi_sum
1391 if (
present(all))
then 1396 if (
present(string))
then 1397 lstring = trim(subname)//
":"//trim(string)
1399 lstring = trim(subname)
1405 if (lsize /= gsize)
then 1406 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1410 call mpi_allreduce(lvec,gvec,gsize,mpi_integer8,reduce_type,comm,ierr)
1413 call mpi_reduce(lvec,gvec,gsize,mpi_integer8,reduce_type,0,comm,ierr)
1434 integer(ip_i8_p),
intent(in) :: lvec(:)
1435 integer(ip_i8_p),
intent(out):: gvec(:)
1436 integer(ip_i4_p),
intent(in) :: comm
1437 character(*),
optional,
intent(in) :: string
1438 logical,
optional,
intent(in) :: all
1441 character(*),
parameter :: subname =
'(oasis_mpi_sumb1)' 1443 character(len=256) :: lstring
1444 integer(ip_i4_p) :: reduce_type
1445 integer(ip_i4_p) :: lsize
1446 integer(ip_i4_p) :: gsize
1447 integer(ip_i4_p) :: ierr
1456 reduce_type = mpi_sum
1457 if (
present(all))
then 1462 if (
present(string))
then 1463 lstring = trim(subname)//
":"//trim(string)
1465 lstring = trim(subname)
1471 if (lsize /= gsize)
then 1472 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1476 call mpi_allreduce(lvec,gvec,gsize,mpi_integer8,reduce_type,comm,ierr)
1479 call mpi_reduce(lvec,gvec,gsize,mpi_integer8,reduce_type,0,comm,ierr)
1497 real(ip_double_p),
intent(in) :: lvec
1498 real(ip_double_p),
intent(out):: gvec
1499 integer(ip_i4_p),
intent(in) :: comm
1500 character(*),
optional,
intent(in) :: string
1501 logical,
optional,
intent(in) :: all
1504 character(*),
parameter :: subname =
'(oasis_mpi_sumr0)' 1506 character(len=256) :: lstring
1507 integer(ip_i4_p) :: reduce_type
1508 integer(ip_i4_p) :: lsize
1509 integer(ip_i4_p) :: gsize
1510 integer(ip_i4_p) :: ierr
1519 reduce_type = mpi_sum
1520 if (
present(all))
then 1525 if (
present(string))
then 1526 lstring = trim(subname)//
":"//trim(string)
1528 lstring = trim(subname)
1534 if (lsize /= gsize)
then 1535 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1539 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1542 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1563 real(ip_double_p),
intent(in) :: lvec(:)
1564 real(ip_double_p),
intent(out):: gvec(:)
1565 integer(ip_i4_p),
intent(in) :: comm
1566 character(*),
optional,
intent(in) :: string
1567 logical,
optional,
intent(in) :: all
1570 character(*),
parameter :: subname =
'(oasis_mpi_sumr1)' 1572 character(len=256) :: lstring
1573 integer(ip_i4_p) :: reduce_type
1574 integer(ip_i4_p) :: lsize
1575 integer(ip_i4_p) :: gsize
1576 integer(ip_i4_p) :: ierr
1585 reduce_type = mpi_sum
1586 if (
present(all))
then 1591 if (
present(string))
then 1592 lstring = trim(subname)//
":"//trim(string)
1594 lstring = trim(subname)
1600 if (lsize /= gsize)
then 1601 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1605 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1608 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1629 real(ip_double_p),
intent(in) :: lvec(:,:)
1630 real(ip_double_p),
intent(out):: gvec(:,:)
1631 integer(ip_i4_p),
intent(in) :: comm
1632 character(*),
optional,
intent(in) :: string
1633 logical,
optional,
intent(in) :: all
1636 character(*),
parameter :: subname =
'(oasis_mpi_sumr2)' 1638 character(len=256) :: lstring
1639 integer(ip_i4_p) :: reduce_type
1640 integer(ip_i4_p) :: lsize
1641 integer(ip_i4_p) :: gsize
1642 integer(ip_i4_p) :: ierr
1651 reduce_type = mpi_sum
1652 if (
present(all))
then 1657 if (
present(string))
then 1658 lstring = trim(subname)//
":"//trim(string)
1660 lstring = trim(subname)
1666 if (lsize /= gsize)
then 1667 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1671 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1674 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1695 real(ip_double_p),
intent(in) :: lvec(:,:,:)
1696 real(ip_double_p),
intent(out):: gvec(:,:,:)
1697 integer(ip_i4_p),
intent(in) :: comm
1698 character(*),
optional,
intent(in) :: string
1699 logical,
optional,
intent(in) :: all
1702 character(*),
parameter :: subname =
'(oasis_mpi_sumr3)' 1704 character(len=256) :: lstring
1705 integer(ip_i4_p) :: reduce_type
1706 integer(ip_i4_p) :: lsize
1707 integer(ip_i4_p) :: gsize
1708 integer(ip_i4_p) :: ierr
1717 reduce_type = mpi_sum
1718 if (
present(all))
then 1723 if (
present(string))
then 1724 lstring = trim(subname)//
":"//trim(string)
1726 lstring = trim(subname)
1732 if (lsize /= gsize)
then 1733 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1737 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1740 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1750 #ifndef __NO_16BYTE_REALS 1760 real(ip_quad_p),
intent(in) :: lvec
1761 real(ip_quad_p),
intent(out):: gvec
1762 integer(ip_i4_p),
intent(in) :: comm
1763 character(*),
optional,
intent(in) :: string
1764 logical,
optional,
intent(in) :: all
1767 character(*),
parameter :: subname =
'(oasis_mpi_sumq0)' 1769 character(len=256) :: lstring
1770 integer(ip_i4_p) :: reduce_type
1771 integer(ip_i4_p) :: lsize
1772 integer(ip_i4_p) :: gsize
1773 integer(ip_i4_p) :: ierr
1782 reduce_type = mpi_sum
1783 if (
present(all))
then 1788 if (
present(string))
then 1789 lstring = trim(subname)//
":"//trim(string)
1791 lstring = trim(subname)
1797 if (lsize /= gsize)
then 1798 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1802 call mpi_allreduce(lvec,gvec,gsize,mpi_real16,reduce_type,comm,ierr)
1805 call mpi_reduce(lvec,gvec,gsize,mpi_real16,reduce_type,0,comm,ierr)
1826 real(ip_quad_p),
intent(in) :: lvec(:)
1827 real(ip_quad_p),
intent(out):: gvec(:)
1828 integer(ip_i4_p),
intent(in) :: comm
1829 character(*),
optional,
intent(in) :: string
1830 logical,
optional,
intent(in) :: all
1833 character(*),
parameter :: subname =
'(oasis_mpi_sumq1)' 1835 character(len=256) :: lstring
1836 integer(ip_i4_p) :: reduce_type
1837 integer(ip_i4_p) :: lsize
1838 integer(ip_i4_p) :: gsize
1839 integer(ip_i4_p) :: ierr
1848 reduce_type = mpi_sum
1849 if (
present(all))
then 1854 if (
present(string))
then 1855 lstring = trim(subname)//
":"//trim(string)
1857 lstring = trim(subname)
1863 if (lsize /= gsize)
then 1864 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1868 call mpi_allreduce(lvec,gvec,gsize,mpi_real16,reduce_type,comm,ierr)
1871 call mpi_reduce(lvec,gvec,gsize,mpi_real16,reduce_type,0,comm,ierr)
1892 real(ip_quad_p),
intent(in) :: lvec(:,:)
1893 real(ip_quad_p),
intent(out):: gvec(:,:)
1894 integer(ip_i4_p),
intent(in) :: comm
1895 character(*),
optional,
intent(in) :: string
1896 logical,
optional,
intent(in) :: all
1899 character(*),
parameter :: subname =
'(oasis_mpi_sumq2)' 1901 character(len=256) :: lstring
1902 integer(ip_i4_p) :: reduce_type
1903 integer(ip_i4_p) :: lsize
1904 integer(ip_i4_p) :: gsize
1905 integer(ip_i4_p) :: ierr
1914 reduce_type = mpi_sum
1915 if (
present(all))
then 1920 if (
present(string))
then 1921 lstring = trim(subname)//
":"//trim(string)
1923 lstring = trim(subname)
1929 if (lsize /= gsize)
then 1930 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
1934 call mpi_allreduce(lvec,gvec,gsize,mpi_real16,reduce_type,comm,ierr)
1937 call mpi_reduce(lvec,gvec,gsize,mpi_real16,reduce_type,0,comm,ierr)
1958 real(ip_quad_p),
intent(in) :: lvec(:,:,:)
1959 real(ip_quad_p),
intent(out):: gvec(:,:,:)
1960 integer(ip_i4_p),
intent(in) :: comm
1961 character(*),
optional,
intent(in) :: string
1962 logical,
optional,
intent(in) :: all
1965 character(*),
parameter :: subname =
'(oasis_mpi_sumq3)' 1967 character(len=256) :: lstring
1968 integer(ip_i4_p) :: reduce_type
1969 integer(ip_i4_p) :: lsize
1970 integer(ip_i4_p) :: gsize
1971 integer(ip_i4_p) :: ierr
1980 reduce_type = mpi_sum
1981 if (
present(all))
then 1986 if (
present(string))
then 1987 lstring = trim(subname)//
":"//trim(string)
1989 lstring = trim(subname)
1995 if (lsize /= gsize)
then 1996 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2000 call mpi_allreduce(lvec,gvec,gsize,mpi_real16,reduce_type,comm,ierr)
2003 call mpi_reduce(lvec,gvec,gsize,mpi_real16,reduce_type,0,comm,ierr)
2023 integer(ip_i4_p),
intent(in) :: lvec
2024 integer(ip_i4_p),
intent(out):: gvec
2025 integer(ip_i4_p),
intent(in) :: comm
2026 character(*),
optional,
intent(in) :: string
2027 logical,
optional,
intent(in) :: all
2030 character(*),
parameter :: subname =
'(oasis_mpi_mini0)' 2032 character(len=256) :: lstring
2033 integer(ip_i4_p) :: reduce_type
2034 integer(ip_i4_p) :: lsize
2035 integer(ip_i4_p) :: gsize
2036 integer(ip_i4_p) :: ierr
2045 reduce_type = mpi_min
2046 if (
present(all))
then 2051 if (
present(string))
then 2052 lstring = trim(subname)//
":"//trim(string)
2054 lstring = trim(subname)
2060 if (lsize /= gsize)
then 2061 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2065 call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
2068 call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
2086 integer(ip_i4_p),
intent(in) :: lvec(:)
2087 integer(ip_i4_p),
intent(out):: gvec(:)
2088 integer(ip_i4_p),
intent(in) :: comm
2089 character(*),
optional,
intent(in) :: string
2090 logical,
optional,
intent(in) :: all
2093 character(*),
parameter :: subname =
'(oasis_mpi_mini1)' 2095 character(len=256) :: lstring
2096 integer(ip_i4_p) :: reduce_type
2097 integer(ip_i4_p) :: lsize
2098 integer(ip_i4_p) :: gsize
2099 integer(ip_i4_p) :: ierr
2108 reduce_type = mpi_min
2109 if (
present(all))
then 2114 if (
present(string))
then 2115 lstring = trim(subname)//
":"//trim(string)
2117 lstring = trim(subname)
2123 if (lsize /= gsize)
then 2124 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2128 call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
2131 call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
2149 real(ip_double_p),
intent(in) :: lvec
2150 real(ip_double_p),
intent(out):: gvec
2151 integer(ip_i4_p),
intent(in) :: comm
2152 character(*),
optional,
intent(in) :: string
2153 logical,
optional,
intent(in) :: all
2156 character(*),
parameter :: subname =
'(oasis_mpi_minr0)' 2158 character(len=256) :: lstring
2159 integer(ip_i4_p) :: reduce_type
2160 integer(ip_i4_p) :: lsize
2161 integer(ip_i4_p) :: gsize
2162 integer(ip_i4_p) :: ierr
2171 reduce_type = mpi_min
2172 if (
present(all))
then 2177 if (
present(string))
then 2178 lstring = trim(subname)//
":"//trim(string)
2180 lstring = trim(subname)
2186 if (lsize /= gsize)
then 2187 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2191 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
2194 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
2212 real(ip_double_p),
intent(in) :: lvec(:)
2213 real(ip_double_p),
intent(out):: gvec(:)
2214 integer(ip_i4_p),
intent(in) :: comm
2215 character(*),
optional,
intent(in) :: string
2216 logical,
optional,
intent(in) :: all
2219 character(*),
parameter :: subname =
'(oasis_mpi_minr1)' 2221 character(len=256) :: lstring
2222 integer(ip_i4_p) :: reduce_type
2223 integer(ip_i4_p) :: lsize
2224 integer(ip_i4_p) :: gsize
2225 integer(ip_i4_p) :: ierr
2234 reduce_type = mpi_min
2235 if (
present(all))
then 2240 if (
present(string))
then 2241 lstring = trim(subname)//
":"//trim(string)
2243 lstring = trim(subname)
2249 if (lsize /= gsize)
then 2250 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2254 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
2257 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
2275 integer(ip_i4_p),
intent(in) :: lvec
2276 integer(ip_i4_p),
intent(out):: gvec
2277 integer(ip_i4_p),
intent(in) :: comm
2278 character(*),
optional,
intent(in) :: string
2279 logical,
optional,
intent(in) :: all
2282 character(*),
parameter :: subname =
'(oasis_mpi_maxi0)' 2284 character(len=256) :: lstring
2285 integer(ip_i4_p) :: reduce_type
2286 integer(ip_i4_p) :: lsize
2287 integer(ip_i4_p) :: gsize
2288 integer(ip_i4_p) :: ierr
2297 reduce_type = mpi_max
2298 if (
present(all))
then 2303 if (
present(string))
then 2304 lstring = trim(subname)//
":"//trim(string)
2306 lstring = trim(subname)
2312 if (lsize /= gsize)
then 2313 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2317 call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
2320 call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
2338 integer(ip_i4_p),
intent(in) :: lvec(:)
2339 integer(ip_i4_p),
intent(out):: gvec(:)
2340 integer(ip_i4_p),
intent(in) :: comm
2341 character(*),
optional,
intent(in) :: string
2342 logical,
optional,
intent(in) :: all
2345 character(*),
parameter :: subname =
'(oasis_mpi_maxi1)' 2347 character(len=256) :: lstring
2348 integer(ip_i4_p) :: reduce_type
2349 integer(ip_i4_p) :: lsize
2350 integer(ip_i4_p) :: gsize
2351 integer(ip_i4_p) :: ierr
2360 reduce_type = mpi_max
2361 if (
present(all))
then 2366 if (
present(string))
then 2367 lstring = trim(subname)//
":"//trim(string)
2369 lstring = trim(subname)
2375 if (lsize /= gsize)
then 2376 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2380 call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
2383 call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
2401 real(ip_double_p),
intent(in) :: lvec
2402 real(ip_double_p),
intent(out):: gvec
2403 integer(ip_i4_p),
intent(in) :: comm
2404 character(*),
optional,
intent(in) :: string
2405 logical,
optional,
intent(in) :: all
2408 character(*),
parameter :: subname =
'(oasis_mpi_maxr0)' 2410 character(len=256) :: lstring
2411 integer(ip_i4_p) :: reduce_type
2412 integer(ip_i4_p) :: lsize
2413 integer(ip_i4_p) :: gsize
2414 integer(ip_i4_p) :: ierr
2423 reduce_type = mpi_max
2424 if (
present(all))
then 2429 if (
present(string))
then 2430 lstring = trim(subname)//
":"//trim(string)
2432 lstring = trim(subname)
2438 if (lsize /= gsize)
then 2439 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2443 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
2446 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
2464 real(ip_double_p),
intent(in) :: lvec(:)
2465 real(ip_double_p),
intent(out):: gvec(:)
2466 integer(ip_i4_p) ,
intent(in) :: comm
2467 character(*),
optional,
intent(in) :: string
2468 logical,
optional,
intent(in) :: all
2471 character(*),
parameter :: subname =
'(oasis_mpi_maxr1)' 2473 character(len=256) :: lstring
2474 integer(ip_i4_p) :: reduce_type
2475 integer(ip_i4_p) :: lsize
2476 integer(ip_i4_p) :: gsize
2477 integer(ip_i4_p) :: ierr
2486 reduce_type = mpi_max
2487 if (
present(all))
then 2492 if (
present(string))
then 2493 lstring = trim(subname)//
":"//trim(string)
2495 lstring = trim(subname)
2501 if (lsize /= gsize)
then 2502 call oasis_mpi_abort(subname//
" lsize,gsize incompatable "//trim(string))
2506 call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
2509 call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
2527 integer,
intent(in) :: comm
2528 integer,
intent(out) :: size
2529 character(*),
optional,
intent(in) :: string
2532 character(*),
parameter :: subname =
'(oasis_mpi_commsize)' 2533 integer(ip_i4_p) :: ierr
2541 call mpi_comm_size(comm,
size,ierr)
2542 if (
present(string))
then 2562 integer,
intent(in) :: comm
2563 integer,
intent(out) :: rank
2564 character(*),
optional,
intent(in) :: string
2567 character(*),
parameter :: subname =
'(oasis_mpi_commrank)' 2568 integer(ip_i4_p) :: ierr
2576 call mpi_comm_rank(comm,rank,ierr)
2577 if (
present(string))
then 2597 logical,
intent(out) :: flag
2598 character(*),
optional,
intent(in) :: string
2601 character(*),
parameter :: subName =
'(oasis_mpi_initialized)' 2602 integer(ip_i4_p) :: ierr
2610 call mpi_initialized(flag,ierr)
2611 if (
present(string))
then 2631 real(ip_r8_p),
intent(out) :: wtime
2634 character(*),
parameter :: subName =
'(oasis_mpi_wtime)' 2658 character(*),
optional,
intent(in) :: string
2659 integer,
optional,
intent(in) :: rcode
2662 character(*),
parameter :: subName =
'(oasis_mpi_abort)' 2663 character(len=256) :: lstr
2664 integer(ip_i4_p) :: ierr
2673 if (
present(string) .and.
present(rcode))
then 2674 write(lstr,
'(a,i6.6)') trim(string)//
' rcode = ',rcode
2675 elseif (
present(string))
then 2681 IF (
PRESENT(rcode))
THEN 2682 CALL oasis_abort(cd_routine=subname,cd_message=trim(string),file=__file__,line=__line__,rcode=rcode)
2684 CALL oasis_abort(cd_routine=subname,cd_message=trim(string),file=__file__,line=__line__)
2701 integer,
intent(in) :: comm
2702 character(*),
optional,
intent(in) :: string
2705 character(*),
parameter :: subname =
'(oasis_mpi_barrier)' 2706 integer(ip_i4_p) :: ierr
2714 call mpi_barrier(comm,ierr)
2715 if (
present(string))
then 2735 character(*),
optional,
intent(in) :: string
2738 character(*),
parameter :: subname =
'(oasis_mpi_init)' 2739 integer(ip_i4_p) :: ierr
2748 if (
present(string))
then 2768 character(*),
optional,
intent(in) :: string
2771 character(*),
parameter :: subname =
'(oasis_mpi_finalize)' 2772 integer(ip_i4_p) :: ierr
2780 call mpi_finalize(ierr)
2781 if (
present(string))
then 2797 linp2,lout2,spval2,linp3,lout3,spval3,linp4,lout4,spval4)
2802 character(*),
pointer,
intent(in) :: linp1(:)
2803 integer ,
intent(in) :: comm
2804 integer ,
intent(out) :: cntout
2805 character(*),
pointer,
intent(inout) :: lout1(:)
2806 character(*) ,
intent(in) :: callstr
2807 logical ,
intent(in) ,
optional :: fastcheck
2808 logical ,
intent(out) ,
optional :: fastcheckout
2809 character(*),
pointer,
intent(in) ,
optional :: linp2(:)
2810 character(*),
pointer,
intent(inout),
optional :: lout2(:)
2811 character(*) ,
intent(in) ,
optional :: spval2
2812 integer ,
pointer,
intent(in) ,
optional :: linp3(:)
2813 integer ,
pointer,
intent(inout),
optional :: lout3(:)
2814 integer ,
intent(in) ,
optional :: spval3
2815 integer ,
pointer,
intent(in) ,
optional :: linp4(:)
2816 integer ,
pointer,
intent(inout),
optional :: lout4(:)
2817 integer ,
intent(in) ,
optional :: spval4
2820 integer(kind=ip_i4_p) :: m,n,k,p
2821 integer(kind=ip_i4_p) :: llen,lsize
2822 integer(kind=ip_i4_p) :: cnt, cntr
2823 integer(kind=ip_i4_p) :: commrank, commsize
2824 integer(kind=ip_i4_p) :: listcheck, listcheckall
2825 integer(kind=ip_i4_p) :: maxloops, sendid, recvid, kfac
2826 logical :: found, present2, present3, present4
2827 integer(kind=ip_i4_p) :: status(mpi_status_size)
2828 character(len=ic_lvar2),
pointer :: recv_varf1(:),varf1a(:),varf1b(:)
2829 character(len=ic_lvar2),
pointer :: recv_varf2(:),varf2a(:),varf2b(:)
2830 integer(kind=ip_i4_p) ,
pointer :: recv_varf3(:),varf3a(:),varf3b(:)
2831 integer(kind=ip_i4_p) ,
pointer :: recv_varf4(:),varf4a(:),varf4b(:)
2832 character(len=ic_lvar2) :: string
2833 logical,
parameter :: local_timers_on = .false.
2834 integer(ip_i4_p) :: ierr
2835 character(*),
parameter :: subname =
'(oasis_mpi_reducelists)' 2850 string = trim(callstr)
2851 if (
present(fastcheckout)) fastcheckout = .false.
2859 if ((
present(linp2) .and. .not.
present(lout2)) .or. &
2860 (
present(lout2) .and. .not.
present(linp2)))
then 2861 call oasis_mpi_abort(subname//trim(string)//
" linp2 lout2 both must be present ")
2863 present2 =
present(linp2)
2865 if ((
present(linp3) .and. .not.
present(lout3)) .or. &
2866 (
present(lout3) .and. .not.
present(linp3)))
then 2867 call oasis_mpi_abort(subname//trim(string)//
" linp3 lout3 both must be present ")
2869 present3 =
present(linp3)
2871 if ((
present(linp4) .and. .not.
present(lout4)) .or. &
2872 (
present(lout4) .and. .not.
present(linp4)))
then 2873 call oasis_mpi_abort(subname//trim(string)//
" linp4 lout4 both must be present ")
2875 present4 =
present(linp4)
2877 if (len(linp1) > len(varf1a))
then 2881 if (
present(linp2))
then 2882 if (
size(linp2) /=
size(linp1))
then 2883 call oasis_mpi_abort(subname//trim(string)//
" linp1 linp2 not same size ")
2885 if (len(linp2) > len(varf2a))
then 2888 if (len(varf1a) /= len(varf2a))
then 2889 call oasis_mpi_abort(subname//trim(string)//
" varf1a varf2a not same len ")
2893 if (
present(linp3))
then 2894 if (
size(linp3) /=
size(linp1))
then 2895 call oasis_mpi_abort(subname//trim(string)//
" linp1 linp3 not same size ")
2899 if (
present(linp4))
then 2900 if (
size(linp4) /=
size(linp1))
then 2901 call oasis_mpi_abort(subname//trim(string)//
" linp1 linp4 not same size ")
2910 if (
present(fastcheck))
then 2916 if (commrank == 0)
then 2919 call oasis_mpi_bcast(lsize, comm, subname//trim(string)//
' lsize check')
2922 allocate(varf1a(lsize))
2924 if (commrank == 0)
then 2925 varf1a(1:lsize) = linp1(1:lsize)
2927 call oasis_mpi_bcast(varf1a, comm, subname//trim(string)//
' varf1a check')
2931 write(
nulprt,*) subname//trim(string),
' sizes ',lsize,
size(linp1)
2933 if (lsize /=
size(linp1)) listcheck = 0
2935 do while (listcheck == 1 .and. n < lsize)
2937 if (varf1a(n) /= linp1(n)) listcheck = 0
2939 write(
nulprt,*) subname//trim(string),
' fcheck varf1a ',n,trim(linp1(n)),
' ',trim(linp1(n)),listcheck
2943 call oasis_mpi_min(listcheck,listcheckall,comm, subname//trim(string)//
' listcheck',all=.true.)
2946 write(
nulprt,*) subname//trim(string),
' listcheck = ',listcheck,listcheckall
2954 if (listcheckall == 1)
then 2956 allocate(lout1(lsize))
2957 lout1(1:lsize) = linp1(1:lsize)
2959 allocate(lout2(lsize))
2960 lout2(1:lsize) = linp2(1:lsize)
2963 allocate(lout3(lsize))
2964 lout3(1:lsize) = linp3(1:lsize)
2967 allocate(lout4(lsize))
2968 lout4(1:lsize) = linp4(1:lsize)
2971 if (
present(fastcheckout)) fastcheckout = .true.
2985 write(
nulprt,*) subname//trim(string),
' len, size = ',llen,lsize
2989 allocate(varf1a(max(lsize,20)))
2990 if (present2)
allocate(varf2a(max(lsize,20)))
2991 if (present3)
allocate(varf3a(max(lsize,20)))
2992 if (present4)
allocate(varf4a(max(lsize,20)))
2997 do while (p < cnt .and. .not.found)
2999 if (linp1(n) == varf1a(p)) found = .true.
3001 if (.not.found)
then 3003 varf1a(cnt) = linp1(n)
3004 if (present2) varf2a(cnt) = linp2(n)
3005 if (present3) varf3a(cnt) = linp3(n)
3006 if (present4) varf4a(cnt) = linp4(n)
3014 maxloops = int(sqrt(float(commsize+1)))+1
3019 recvid = commrank + kfac/2
3020 if (mod(commrank,kfac) /= 0 .or. &
3021 recvid < 0 .or. recvid > commsize-1) &
3024 sendid = commrank - kfac/2
3025 if (mod(commrank+kfac/2,kfac) /= 0 .or. &
3026 sendid < 0 .or. sendid > commsize-1) &
3030 write(
nulprt,*) subname//trim(string),
' send/recv ids ',m,commrank,sendid,recvid
3038 if (sendid >= 0)
then 3040 call mpi_send(cnt, 1, mpi_integer, sendid, 5900+m, comm, ierr)
3044 write(
nulprt,*) subname//trim(string),
' send size ',commrank,m,cnt,
ic_lvar2 3047 call mpi_send(varf1a(1:cnt), cnt*
ic_lvar2, mpi_character, sendid, 6900+m, comm, ierr)
3050 call mpi_send(varf2a(1:cnt), cnt*
ic_lvar2, mpi_character, sendid, 7900+m, comm, ierr)
3054 call mpi_send(varf3a(1:cnt), cnt, mpi_integer, sendid, 8900+m, comm, ierr)
3058 call mpi_send(varf4a(1:cnt), cnt, mpi_integer, sendid, 9900+m, comm, ierr)
3070 if (recvid >= 0)
then 3072 call mpi_recv(cntr, 1, mpi_integer, recvid, 5900+m, comm, status, ierr)
3076 write(
nulprt,*) subname//trim(string),
' recv size ',commrank,m,cntr,
ic_lvar2 3079 allocate(recv_varf1(cntr))
3080 call mpi_recv(recv_varf1, cntr*
ic_lvar2, mpi_character, recvid, 6900+m, comm, status, ierr)
3083 allocate(recv_varf2(cntr))
3084 call mpi_recv(recv_varf2, cntr*
ic_lvar2, mpi_character, recvid, 7900+m, comm, status, ierr)
3088 allocate(recv_varf3(cntr))
3089 call mpi_recv(recv_varf3, cntr, mpi_integer, recvid, 8900+m, comm, status, ierr)
3093 allocate(recv_varf4(cntr))
3094 call mpi_recv(recv_varf4, cntr, mpi_integer, recvid, 9900+m, comm, status, ierr)
3102 if (
oasis_debug >= 15)
write(
nulprt,*) subname//trim(string),
' check recv_varf1 ',m,n,trim(recv_varf1(n))
3106 do while (p < cnt .and. .not.found)
3108 if (recv_varf1(n) == varf1a(p))
then 3111 if (
present(spval2))
then 3113 if (varf2a(p) == spval2)
then 3114 varf2a(p) = recv_varf2(n)
3115 elseif (recv_varf2(n) /= spval2 .and. varf2a(p) /= recv_varf2(n))
then 3116 call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3117 'inconsistent linp2 value: '//trim(recv_varf2(n))//
':'//trim(varf1a(p))//
':'//trim(varf2a(p)), &
3118 file=__file__,line=__line__)
3121 if (varf2a(p) /= recv_varf2(n))
then 3122 call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3123 'inconsistent linp2 value: '//trim(recv_varf2(n))//
':'//trim(varf1a(p))//
':'//trim(varf2a(p)), &
3124 file=__file__,line=__line__)
3129 if (
present(spval3))
then 3131 if (varf3a(p) == spval3)
then 3132 varf3a(p) = recv_varf3(n)
3133 elseif (recv_varf3(n) /= spval3 .and. varf3a(p) /= recv_varf3(n))
then 3134 write(
nulprt,*) subname//trim(string),
astr,
'inconsistent linp3 var: ',&
3135 recv_varf3(n),
':',trim(varf1a(p)),
':',varf3a(p)
3136 call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3137 'inconsistent linp3 value: '//trim(varf1a(p)), &
3138 file=__file__,line=__line__)
3141 if (varf3a(p) /= recv_varf3(n))
then 3142 write(
nulprt,*) subname//trim(string),
astr,
'inconsistent linp3 var: ',&
3143 recv_varf3(n),
':',trim(varf1a(p)),
':',varf3a(p)
3144 call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3145 'inconsistent linp3 value: '//trim(varf1a(p)), &
3146 file=__file__,line=__line__)
3151 if (
present(spval4))
then 3153 if (varf4a(p) == spval4)
then 3154 varf4a(p) = recv_varf4(n)
3155 elseif (recv_varf4(n) /= spval4 .and. varf4a(p) /= recv_varf4(n))
then 3156 write(
nulprt,*) subname//trim(string),
astr,
'inconsistent linp4 var: ',&
3157 recv_varf4(n),
':',trim(varf1a(p)),
':',varf4a(p)
3158 call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3159 'inconsistent linp4 value: '//trim(varf1a(p)), &
3160 file=__file__,line=__line__)
3163 if (varf4a(p) /= recv_varf4(n))
then 3164 write(
nulprt,*) subname//trim(string),
astr,
'inconsistent linp4 var: ',&
3165 recv_varf4(n),
':',trim(varf1a(p)),
':',varf4a(p)
3166 call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3167 'inconsistent linp4 value: '//trim(varf1a(p)), &
3168 file=__file__,line=__line__)
3174 if (.not.found)
then 3176 if (cnt >
size(varf1a))
then 3177 allocate(varf1b(
size(varf1a)))
3181 write(
nulprt,*) subname//trim(string),
' resize varf1a ',
size(varf1b),cnt+cntr
3184 allocate(varf1a(cnt+cntr))
3185 varf1a(1:
size(varf1b)) = varf1b(1:
size(varf1b))
3188 allocate(varf2b(
size(varf2a)))
3192 write(
nulprt,*) subname//trim(string),
' resize varf2a ',
size(varf2b),cnt+cntr
3195 allocate(varf2a(cnt+cntr))
3196 varf2a(1:
size(varf2b)) = varf2b(1:
size(varf2b))
3200 allocate(varf3b(
size(varf3a)))
3204 write(
nulprt,*) subname//trim(string),
' resize varf3a ',
size(varf3b),cnt+cntr
3207 allocate(varf3a(cnt+cntr))
3208 varf3a(1:
size(varf3b)) = varf3b(1:
size(varf3b))
3212 allocate(varf4b(
size(varf4a)))
3216 write(
nulprt,*) subname//trim(string),
' resize varf4a ',
size(varf4b),cnt+cntr
3219 allocate(varf4a(cnt+cntr))
3220 varf4a(1:
size(varf4b)) = varf4b(1:
size(varf4b))
3224 varf1a(cnt) = recv_varf1(n)
3225 if (present2) varf2a(cnt) = recv_varf2(n)
3226 if (present3) varf3a(cnt) = recv_varf3(n)
3227 if (present4) varf4a(cnt) = recv_varf4(n)
3232 deallocate(recv_varf1)
3233 if (present2)
deallocate(recv_varf2)
3234 if (present3)
deallocate(recv_varf3)
3235 if (present4)
deallocate(recv_varf4)
3246 if (local_timers_on)
then 3248 if (comm /= mpi_comm_null) &
3249 call mpi_barrier(comm, ierr)
3255 allocate(lout1(cntout))
3256 if (commrank == 0)
then 3258 lout1(n) = trim(varf1a(n))
3265 allocate(lout2(cntout))
3266 if (commrank == 0)
then 3268 lout2(n) = trim(varf2a(n))
3276 allocate(lout3(cntout))
3277 if (commrank == 0)
then 3279 lout3(n) = varf3a(n)
3287 allocate(lout4(cntout))
3288 if (commrank == 0)
then 3290 lout4(n) = varf4a(n)
3301 if (present2 .and. present3 .and. present4)
then 3302 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),
' ',trim(lout2(n)),lout3(n),lout4(n)
3303 elseif (present2 .and. present3)
then 3304 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),
' ',trim(lout2(n)),lout3(n)
3305 elseif (present2 .and. present4)
then 3306 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),
' ',trim(lout2(n)),lout4(n)
3307 elseif (present3 .and. present4)
then 3308 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),
' ',lout3(n),lout4(n)
3309 elseif (present2)
then 3310 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),
' ',trim(lout2(n))
3311 elseif (present3)
then 3312 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),lout3(n)
3313 elseif (present4)
then 3314 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n)),lout4(n)
3316 write(
nulprt,*) subname,trim(string),
' list: ',n,trim(lout1(n))
subroutine oasis_mpi_mini1(lvec, gvec, comm, string, all)
Compute an array of global minimums for an array of 1D integers.
Generic overloaded interface into MPI sum reduction.
Generic interfaces into an MPI vector gather.
subroutine oasis_mpi_bcastr0(vec, comm, string, pebcast)
Broadcast a scalar double.
subroutine, public oasis_mpi_chkerr(rcode, string)
Checks MPI error codes and aborts.
integer, parameter ic_lvar2
character(len= *), parameter, public astr
Provides a common location for several OASIS variables.
subroutine oasis_mpi_bcasti1(vec, comm, string, pebcast)
Broadcast an array of 1D integers.
Generic overloaded interface into MPI send.
Generic overloaded interface into MPI max reduction.
subroutine oasis_mpi_bcastl1(vec, comm, string, pebcast)
Broadcast an array of 1D logicals.
subroutine oasis_mpi_sumq0(lvec, gvec, comm, string, all)
Compute a global sum for a scalar quad.
integer(kind=ip_intwp_p) nulprt
Generic overloaded interface into MPI broadcast.
subroutine oasis_mpi_maxi0(lvec, gvec, comm, string, all)
Compute a global maximum for a scalar integer.
subroutine oasis_mpi_maxr1(lvec, gvec, comm, string, all)
Compute an array of global maximums for an array of 1D doubles.
subroutine oasis_mpi_bcastc1(vec, comm, string, pebcast)
Broadcast an array of 1D character strings.
subroutine, public oasis_mpi_abort(string, rcode)
Write error messages and Call MPI_ABORT.
subroutine, public oasis_abort(id_compid, cd_routine, cd_message, file, line, rcode)
OASIS abort method, publically available to users.
subroutine oasis_mpi_mini0(lvec, gvec, comm, string, all)
Compute a global minimum for a scalar integer.
subroutine oasis_mpi_bcastr3(arr, comm, string, pebcast)
Broadcast an array of 3D doubles.
subroutine, public oasis_mpi_init(string)
Call MPI_INIT.
subroutine oasis_mpi_sendi1(lvec, pid, tag, comm, string)
Send an array of 1D integers.
subroutine oasis_mpi_sumr3(lvec, gvec, comm, string, all)
Compute a 3D array of global sums for an array of 3D doubles.
Generic interfaces into an MPI vector scatter.
subroutine oasis_mpi_maxi1(lvec, gvec, comm, string, all)
Compute an array of global maximums for an array of 1D integers.
subroutine oasis_mpi_sumq3(lvec, gvec, comm, string, all)
Compute a 3D array of global sums for an array of 3D quads.
subroutine, public oasis_mpi_initialized(flag, string)
Check whether MPI has been initialized.
subroutine oasis_mpi_sumi1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D integers.
subroutine oasis_mpi_recvr3(array, pid, tag, comm, string)
Receive an array of 3D doubles.
Provides a generic and simpler interface into MPI calls for OASIS.
subroutine oasis_mpi_sumb1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D 8 byte integers.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
Generic overloaded interface into MPI min reduction.
subroutine oasis_mpi_gathscatvinitr1(comm, rootid, locArr, glob1DArr, globSize, displs, string)
Initialize variables for oasis_mpi_gatherv and oasis_mpi_scatterv.
subroutine, public oasis_mpi_reducelists(linp1, comm, cntout, lout1, callstr, fastcheck, fastcheckout, linp2, lout2, spval2, linp3, lout3, spval3, linp4, lout4, spval4)
Custom method for reducing MPI lists across pes for OASIS.
subroutine oasis_mpi_minr0(lvec, gvec, comm, string, all)
Compute an global minimum for a scalar double.
subroutine oasis_mpi_bcastc0(vec, comm, string, pebcast)
Broadcast a character string.
subroutine oasis_mpi_sumq1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D quads.
subroutine oasis_mpi_sendi0(lvec, pid, tag, comm, string)
Send a scalar integer.
Generic interface to oasis_mpi_gathScatVInit.
subroutine, public oasis_timer_start(timer_label, barrier)
Start a timer.
integer(kind=ip_i4_p) oasis_debug
subroutine, public oasis_timer_stop(timer_label)
Stop a timer.
subroutine, public oasis_mpi_barrier(comm, string)
Call MPI_BARRIER for a particular communicator.
subroutine, public oasis_mpi_commsize(comm, size, string)
Get the total number of tasks associated with a communicator.
subroutine oasis_mpi_recvr1(lvec, pid, tag, comm, string)
Receive an array of 1D doubles.
subroutine oasis_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, comm, string)
Scatter a vector of global data from a rootid.
subroutine oasis_mpi_maxr0(lvec, gvec, comm, string, all)
Compute a global maximum for a scalar double.
subroutine oasis_mpi_recvi0(lvec, pid, tag, comm, string)
Receive a scalar integer.
subroutine, public oasis_mpi_wtime(wtime)
Return a timestamp from MPI_WTIME.
subroutine oasis_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, comm, string)
Gather a vector of distributed data to a rootid.
subroutine oasis_mpi_sumi0(lvec, gvec, comm, string, all)
Compute a global Sum for a scalar integer.
subroutine oasis_mpi_bcastr2(arr, comm, string, pebcast)
Broadcast an array of 2D doubles.
subroutine, public oasis_flush(nu)
Flushes output to file.
subroutine oasis_mpi_recvi1(lvec, pid, tag, comm, string)
Receive an array of 1D integers.
subroutine oasis_mpi_sendr0(lvec, pid, tag, comm, string)
Send a scalar double.
subroutine oasis_mpi_bcastr1(vec, comm, string, pebcast)
Broadcast an array of 1D doubles.
subroutine oasis_mpi_sumq2(lvec, gvec, comm, string, all)
Compute a 2D array of global sums for an array of 2D quads.
subroutine, public oasis_mpi_finalize(string)
Call MPI_FINALZE.
subroutine oasis_mpi_sumb0(lvec, gvec, comm, string, all)
Compute a global sum for a scalar 8 byte integer.
Performance timer methods.
subroutine oasis_mpi_bcasti0(vec, comm, string, pebcast)
Broadcast a scalar integer.
subroutine oasis_mpi_bcastl0(vec, comm, string, pebcast)
Broadcast a scalar logical.
subroutine oasis_mpi_sumr0(lvec, gvec, comm, string, all)
Compute a global sum for a scalar double.
subroutine oasis_mpi_sendr1(lvec, pid, tag, comm, string)
Send an array of 1D doubles.
subroutine oasis_mpi_sumr1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D doubles.
Generic overloaded interface into MPI receive.
subroutine oasis_mpi_sumr2(lvec, gvec, comm, string, all)
Compute a 2D array of global sums for an array of 2D doubles.
subroutine oasis_mpi_minr1(lvec, gvec, comm, string, all)
Compute an array of global minimums for an array of 1D doubles.
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
subroutine, public oasis_mpi_commrank(comm, rank, string)
Get the rank (task ID) for a task in a communicator.
subroutine oasis_mpi_sendr3(array, pid, tag, comm, string)
Send an array of 3D doubles.
subroutine oasis_mpi_recvr0(lvec, pid, tag, comm, string)
Receive a scalar double.
subroutine oasis_mpi_bcasti2(arr, comm, string, pebcast)
Broadcast an array of 2D integers.