Changeset 963 for codes/icosagcm/trunk/src
- Timestamp:
- 07/25/19 11:36:36 (5 years ago)
- Location:
- codes/icosagcm/trunk/src
- Files:
-
- 2 added
- 8 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
codes/icosagcm/trunk/src/base/field.f90
r953 r963 13 13 TYPE t_field 14 14 CHARACTER(30) :: name 15 REAL(rstd),POINTER :: rval2d(:) => null()16 REAL(rstd),POINTER :: rval3d(:,:) => null()17 REAL(rstd),POINTER :: rval4d(:,:,:) => null()15 REAL(rstd),POINTER, CONTIGUOUS :: rval2d(:) => null() 16 REAL(rstd),POINTER, CONTIGUOUS :: rval3d(:,:) => null() 17 REAL(rstd),POINTER, CONTIGUOUS :: rval4d(:,:,:) => null() 18 18 19 19 INTEGER,POINTER :: ival2d(:) … … 274 274 IF (field(ind)%ndim==4) THEN 275 275 IF (data_type==type_integer) THEN 276 IF (field(ind)%ondevice) THEN 277 !$acc exit data delete(field(ind)%ival4d(:,:,:)) 278 CONTINUE 279 END IF 276 280 DEALLOCATE(field(ind)%ival4d) 277 IF (field(ind)%ondevice) THEN278 !$acc exit data delete(field(ind)%ival4d)279 CONTINUE280 END IF281 281 END IF 282 282 283 283 IF (data_type==type_real) THEN 284 IF (field(ind)%ondevice) THEN 285 !$acc exit data delete(field(ind)%rval4d(:,:,:)) 286 CONTINUE 287 END IF 284 288 DEALLOCATE(field(ind)%rval4d) 285 IF (field(ind)%ondevice) THEN286 !$acc exit data delete(field(ind)%rval4d)287 CONTINUE288 END IF289 289 END IF 290 290 291 291 IF (data_type==type_logical) THEN 292 IF (field(ind)%ondevice) THEN 293 !$acc exit data delete(field(ind)%lval4d(:,:,:)) 294 CONTINUE 295 END IF 292 296 DEALLOCATE(field(ind)%lval4d) 293 IF (field(ind)%ondevice) THEN294 !$acc exit data delete(field(ind)%lval4d)295 CONTINUE296 END IF297 297 END IF 298 298 299 299 ELSE IF (field(ind)%ndim==3) THEN 300 300 IF (data_type==type_integer) THEN 301 IF (field(ind)%ondevice) THEN 302 !$acc exit data delete(field(ind)%ival3d(:,:)) 303 CONTINUE 304 END IF 301 305 DEALLOCATE(field(ind)%ival3d) 302 IF (field(ind)%ondevice) THEN303 !$acc exit data delete(field(ind)%ival3d)304 CONTINUE305 END IF306 306 END IF 307 307 308 308 IF (data_type==type_real) THEN 309 IF (field(ind)%ondevice) THEN 310 !$acc exit data delete(field(ind)%rval3d(:,:)) 311 CONTINUE 312 END IF 309 313 DEALLOCATE(field(ind)%rval3d) 310 IF (field(ind)%ondevice) THEN311 !$acc exit data delete(field(ind)%rval3d)312 CONTINUE313 END IF314 314 END IF 315 315 316 316 IF (data_type==type_logical) THEN 317 IF (field(ind)%ondevice) THEN 318 !$acc exit data delete(field(ind)%lval3d(:,:)) 319 CONTINUE 320 END IF 317 321 DEALLOCATE(field(ind)%lval3d) 318 IF (field(ind)%ondevice) THEN319 !$acc exit data delete(field(ind)%lval3d)320 CONTINUE321 END IF322 322 END IF 323 323 324 324 ELSE IF (field(ind)%ndim==2) THEN 325 325 IF (data_type==type_integer) THEN 326 IF (field(ind)%ondevice) THEN 327 !$acc exit data delete(field(ind)%ival2d(:)) 328 CONTINUE 329 END IF 326 330 DEALLOCATE(field(ind)%ival2d) 327 IF (field(ind)%ondevice) THEN328 !$acc exit data delete(field(ind)%ival2d)329 CONTINUE330 END IF331 331 END IF 332 332 333 333 IF (data_type==type_real) THEN 334 IF (field(ind)%ondevice) THEN 335 !$acc exit data delete(field(ind)%rval2d(:)) 336 CONTINUE 337 END IF 334 338 DEALLOCATE(field(ind)%rval2d) 335 IF (field(ind)%ondevice) THEN336 !$acc exit data delete(field(ind)%rval2d)337 CONTINUE338 END IF339 339 END IF 340 340 341 341 IF (data_type==type_logical) THEN 342 IF (field(ind)%ondevice) THEN 343 !$acc exit data delete(field(ind)%lval2d(:)) 344 CONTINUE 345 END IF 342 346 DEALLOCATE(field(ind)%lval2d) 343 IF (field(ind)%ondevice) THEN344 !$acc exit data delete(field(ind)%lval2d)345 CONTINUE346 END IF347 347 END IF 348 348 349 349 ENDIF 350 351 350 ENDDO 352 351 END SUBROUTINE deallocate_field_ … … 555 554 IF (field(ind)%ndim==4) THEN 556 555 IF (field(ind)%data_type==type_integer) THEN 557 !$acc update device(field(ind)%ival4d(:,:,:)) 556 !$acc update device(field(ind)%ival4d(:,:,:)) async 558 557 CONTINUE 559 558 END IF 560 559 561 560 IF (field(ind)%data_type==type_real) THEN 562 !$acc update device(field(ind)%rval4d(:,:,:)) 561 !$acc update device(field(ind)%rval4d(:,:,:)) async 563 562 CONTINUE 564 563 END IF 565 564 566 565 IF (field(ind)%data_type==type_logical) THEN 567 !$acc update device(field(ind)%lval4d(:,:,:)) 566 !$acc update device(field(ind)%lval4d(:,:,:)) async 568 567 CONTINUE 569 568 END IF … … 571 570 ELSE IF (field(ind)%ndim==3) THEN 572 571 IF (field(ind)%data_type==type_integer) THEN 573 !$acc update device(field(ind)%ival3d(:,:)) 572 !$acc update device(field(ind)%ival3d(:,:)) async 574 573 CONTINUE 575 574 END IF 576 575 577 576 IF (field(ind)%data_type==type_real) THEN 578 !$acc update device(field(ind)%rval3d(:,:)) 577 !$acc update device(field(ind)%rval3d(:,:)) async 579 578 CONTINUE 580 579 END IF 581 580 582 581 IF (field(ind)%data_type==type_logical) THEN 583 !$acc update device(field(ind)%lval3d(:,:)) 582 !$acc update device(field(ind)%lval3d(:,:)) async 584 583 CONTINUE 585 584 END IF … … 587 586 ELSE IF (field(ind)%ndim==2) THEN 588 587 IF (field(ind)%data_type==type_integer) THEN 589 !$acc update device(field(ind)%ival2d(:)) 588 !$acc update device(field(ind)%ival2d(:)) async 590 589 CONTINUE 591 590 END IF 592 591 593 592 IF (field(ind)%data_type==type_real) THEN 594 !$acc update device(field(ind)%rval2d(:)) 593 !$acc update device(field(ind)%rval2d(:)) async 595 594 CONTINUE 596 595 END IF 597 596 598 597 IF (field(ind)%data_type==type_logical) THEN 599 !$acc update device(field(ind)%lval2d(:)) 598 !$acc update device(field(ind)%lval2d(:)) async 600 599 CONTINUE 601 600 END IF … … 616 615 617 616 IF (field(ind)%ondevice) THEN 618 617 619 618 IF (field(ind)%ndim==4) THEN 620 619 IF (field(ind)%data_type==type_integer) THEN 621 !$acc update host(field(ind)%ival4d(:,:,:)) wait620 !$acc update host(field(ind)%ival4d(:,:,:)) async 622 621 CONTINUE 623 622 END IF 624 623 625 624 IF (field(ind)%data_type==type_real) THEN 626 !$acc update host(field(ind)%rval4d(:,:,:)) wait625 !$acc update host(field(ind)%rval4d(:,:,:)) async 627 626 CONTINUE 628 627 END IF 629 628 630 629 IF (field(ind)%data_type==type_logical) THEN 631 !$acc update host(field(ind)%lval4d(:,:,:)) wait632 CONTINUE 633 END IF 634 630 !$acc update host(field(ind)%lval4d(:,:,:)) async 631 CONTINUE 632 END IF 633 635 634 ELSE IF (field(ind)%ndim==3) THEN 636 635 IF (field(ind)%data_type==type_integer) THEN 637 !$acc update host(field(ind)%ival3d(:,:)) wait636 !$acc update host(field(ind)%ival3d(:,:)) async 638 637 CONTINUE 639 638 END IF 640 639 641 640 IF (field(ind)%data_type==type_real) THEN 642 !$acc update host(field(ind)%rval3d(:,:)) wait641 !$acc update host(field(ind)%rval3d(:,:)) async 643 642 CONTINUE 644 643 END IF 645 644 646 645 IF (field(ind)%data_type==type_logical) THEN 647 !$acc update host(field(ind)%lval3d(:,:)) wait646 !$acc update host(field(ind)%lval3d(:,:)) async 648 647 CONTINUE 649 648 END IF … … 651 650 ELSE IF (field(ind)%ndim==2) THEN 652 651 IF (field(ind)%data_type==type_integer) THEN 653 !$acc update host(field(ind)%ival2d(:)) wait652 !$acc update host(field(ind)%ival2d(:)) async 654 653 CONTINUE 655 654 END IF 656 655 657 656 IF (field(ind)%data_type==type_real) THEN 658 !$acc update host(field(ind)%rval2d(:)) wait657 !$acc update host(field(ind)%rval2d(:)) async 659 658 CONTINUE 660 659 END IF 661 660 662 661 IF (field(ind)%data_type==type_logical) THEN 663 !$acc update host(field(ind)%lval2d(:)) wait662 !$acc update host(field(ind)%lval2d(:)) async 664 663 CONTINUE 665 664 END IF … … 667 666 END IF 668 667 ENDDO 668 !$acc wait 669 669 !$OMP BARRIER 670 670 END SUBROUTINE update_host_field … … 679 679 IF (field%ndim==4) THEN 680 680 IF (field%data_type==type_integer) THEN 681 !$acc enter data create(field%ival4d(:,:,:)) 681 !$acc enter data create(field%ival4d(:,:,:)) async 682 682 END IF 683 683 684 684 IF (field%data_type==type_real) THEN 685 !$acc enter data create(field%rval4d(:,:,:)) 685 !$acc enter data create(field%rval4d(:,:,:)) async 686 686 END IF 687 687 688 688 IF (field%data_type==type_logical) THEN 689 !$acc enter data create(field%lval4d(:,:,:)) 689 !$acc enter data create(field%lval4d(:,:,:)) async 690 690 END IF 691 691 692 692 ELSE IF (field%ndim==3) THEN 693 693 IF (field%data_type==type_integer) THEN 694 !$acc enter data create(field%ival3d(:,:)) 694 !$acc enter data create(field%ival3d(:,:)) async 695 695 END IF 696 696 697 697 IF (field%data_type==type_real) THEN 698 !$acc enter data create(field%rval3d(:,:)) 698 !$acc enter data create(field%rval3d(:,:)) async 699 699 END IF 700 700 701 701 IF (field%data_type==type_logical) THEN 702 !$acc enter data create(field%lval3d(:,:)) 702 !$acc enter data create(field%lval3d(:,:)) async 703 703 END IF 704 704 705 705 ELSE IF (field%ndim==2) THEN 706 706 IF (field%data_type==type_integer) THEN 707 !$acc enter data create(field%ival2d(:)) 707 !$acc enter data create(field%ival2d(:)) async 708 708 END IF 709 709 710 710 IF (field%data_type==type_real) THEN 711 !$acc enter data create(field%rval2d(:)) 711 !$acc enter data create(field%rval2d(:)) async 712 712 END IF 713 713 714 714 IF (field%data_type==type_logical) THEN 715 !$acc enter data create(field%lval2d(:)) 715 !$acc enter data create(field%lval2d(:)) async 716 716 END IF 717 717 ENDIF -
codes/icosagcm/trunk/src/dissip/dissip_gcm.F90
r954 r963 4 4 PRIVATE 5 5 6 TYPE(t_field),POINTER,SAVE :: f_due_diss 1(:)7 TYPE(t_field),POINTER,SAVE :: f_due_diss 2(:)6 TYPE(t_field),POINTER,SAVE :: f_due_diss_gradiv(:) 7 TYPE(t_field),POINTER,SAVE :: f_due_diss_gradrot(:) 8 8 9 9 TYPE(t_field),POINTER,SAVE :: f_dtheta_diss(:) 10 10 TYPE(t_field),POINTER,SAVE :: f_dtheta_rhodz_diss(:) 11 TYPE(t_message),SAVE :: req_due , req_dtheta11 TYPE(t_message),SAVE :: req_due_gradiv, req_due_gradrot, req_dtheta 12 12 13 13 INTEGER,SAVE :: nitergdiv=1 … … 47 47 SUBROUTINE allocate_dissip 48 48 USE icosa 49 IMPLICIT NONE 50 CALL allocate_field(f_due_diss 1,field_u,type_real,llm,ondevice=.TRUE.)51 CALL allocate_field(f_due_diss 2,field_u,type_real,llm,ondevice=.TRUE.)49 IMPLICIT NONE 50 CALL allocate_field(f_due_diss_gradiv,field_u,type_real,llm,ondevice=.TRUE.) 51 CALL allocate_field(f_due_diss_gradrot,field_u,type_real,llm,ondevice=.TRUE.) 52 52 CALL allocate_field(f_dtheta_diss,field_t,type_real,llm) 53 53 CALL allocate_field(f_dtheta_rhodz_diss,field_t,type_real,llm,ondevice=.TRUE.) … … 140 140 CALL allocate_field(f_dtheta,field_t,type_real,ondevice=.TRUE.) 141 141 142 CALL init_message(f_due_diss1,req_e1_vect,req_due) 143 CALL init_message(f_dtheta_diss,req_i1,req_dtheta) 142 CALL init_message(f_due_diss_gradiv,req_e1_vect,req_due_gradiv) 143 CALL init_message(f_due_diss_gradrot,req_e1_vect,req_due_gradrot) 144 CALL init_message(f_dtheta_rhodz_diss,req_i1,req_dtheta) 144 145 145 146 tau_graddiv(:)=5000 … … 548 549 549 550 CALL trace_start("dissip") 550 CALL gradiv(f_ue,f_due_diss 1)551 CALL gradrot(f_ue,f_due_diss 2)551 CALL gradiv(f_ue,f_due_diss_gradiv) 552 CALL gradrot(f_ue,f_due_diss_gradrot) 552 553 553 554 CALL divgrad_theta_rhodz(f_mass,f_theta_rhodz,f_dtheta_rhodz_diss) … … 558 559 CALL swap_geometry(ind) 559 560 due=f_due(ind) 560 due_diss1=f_due_diss 1(ind)561 due_diss2=f_due_diss 2(ind)561 due_diss1=f_due_diss_gradiv(ind) 562 due_diss2=f_due_diss_gradrot(ind) 562 563 dtheta_rhodz=f_dtheta_rhodz(ind) 563 564 dtheta_rhodz_diss=f_dtheta_rhodz_diss(ind) … … 653 654 USE output_field_mod 654 655 655 CALL transfert_request(f_due_diss 1,req_e1_vect)656 CALL un2ulonlat(f_due_diss 1, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1))))656 CALL transfert_request(f_due_diss_gradiv,req_e1_vect) 657 CALL un2ulonlat(f_due_diss_gradiv, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1)))) 657 658 CALL output_field("dulon_diss1",f_buf_ulon) 658 659 CALL output_field("dulat_diss1",f_buf_ulat) 659 660 ! 660 CALL transfert_request(f_due_diss 2,req_e1_vect)661 CALL un2ulonlat(f_due_diss 2, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1))))661 CALL transfert_request(f_due_diss_gradrot,req_e1_vect) 662 CALL un2ulonlat(f_due_diss_gradrot, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1)))) 662 663 CALL output_field("dulon_diss2",f_buf_ulon) 663 664 CALL output_field("dulat_diss2",f_buf_ulat) … … 699 700 700 701 DO it=1,nitergdiv 701 CALL send_message(f_due,req_due) 702 CALL wait_message(req_due) 703 702 CALL send_message(f_due,req_due_gradiv) 703 CALL wait_message(req_due_gradiv) 704 704 DO ind=1,ndomain 705 705 IF (.NOT. assigned_domain(ind)) CYCLE … … 749 749 750 750 DO it=1,nitergrot 751 CALL send_message(f_due,req_due )752 CALL wait_message(req_due )751 CALL send_message(f_due,req_due_gradrot) 752 CALL wait_message(req_due_gradrot) 753 753 754 754 DO ind=1,ndomain -
codes/icosagcm/trunk/src/output/write_field.f90
r899 r963 66 66 USE domain_mod 67 67 USE field_mod 68 USE transfert_m pi_mod68 USE transfert_mod 69 69 USE dimensions 70 70 USE mpipara -
codes/icosagcm/trunk/src/parallel/domain.f90
r899 r963 694 694 695 695 ENDDO 696 697 !$acc enter data copyin(assigned_domain(:)) 696 698 697 699 END SUBROUTINE assign_domain_omp -
codes/icosagcm/trunk/src/parallel/transfert.F90
r711 r963 1 MODULE transfert_mod 2 1 module transfert_mod 3 2 #ifdef CPP_USING_MPI 4 USE transfert_mpi_mod, ONLY : init_transfert, transfert_request=>transfert_request_mpi, req_i1,req_e1_vect, & 5 req_e1_scal, req_z1_scal, req_i0, req_e0_vect, req_e0_scal, request_add_point, & 6 create_request, gather_field, scatter_field, & 7 t_message, init_message=>init_message_mpi, & 8 transfert_message=>transfert_message_mpi, & 9 send_message=>send_message_mpi, & 10 test_message=>test_message_mpi, & 11 wait_message=>wait_message_mpi,barrier,bcast_mpi 12 #else 13 USE transfert_mpi_mod, ONLY : init_transfert, transfert_request=>transfert_request_seq, req_i1,req_e1_vect, & 14 req_e1_scal, req_z1_scal, req_i0, req_e0_vect, req_e0_scal, & 15 request_add_point, create_request, gather_field, & 16 scatter_field, t_message, & 17 init_message=>init_message_seq, & 18 transfert_message=>transfert_message_seq, & 19 send_message=>send_message_seq, & 20 test_message=>test_message_seq, & 21 wait_message=>wait_message_seq,barrier, bcast_mpi 3 4 #if defined(CPP_USING_MPI_LEGACY) 5 #warning("Using legacy transfert_mpi (not default)") 6 use transfert_mpi_legacy_mod, only : t_message, t_request, & 7 req_i1, req_e1_scal, req_e1_vect, & 8 req_i0, req_e0_scal, req_e0_vect, & 9 req_z1_scal, & 10 init_transfert, & 11 init_message => init_message_mpi, & 12 finalize_message => finalize_message_mpi, & 13 send_message => send_message_mpi, & 14 wait_message => wait_message_mpi, & 15 test_message => test_message_mpi 16 #else 17 ! transfert_mpi using manual pack/unpack (default) 18 use transfert_mpi_mod, only : t_message, t_request, & 19 req_i1, req_e1_scal, req_e1_vect, & 20 req_i0, req_e0_scal, req_e0_vect, & 21 req_z1_scal, & 22 init_transfert, & 23 init_message, & 24 finalize_message, & 25 send_message, & 26 wait_message, & 27 test_message 22 28 #endif 23 24 USE transfert_omp_mod 25 26 INTERFACE bcast 27 MODULE PROCEDURE bcast_c, & 28 bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & 29 bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & 30 bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 31 32 END INTERFACE 33 34 35 CONTAINS 36 29 #else 30 #warning("Using transfert_seq (unmaintained)") 31 use transfert_mpi_legacy_mod, only : t_message, t_request, & 32 req_i1, req_e1_scal, req_e1_vect, & 33 req_i0, req_e0_scal, req_e0_vect, & 34 req_z1_scal, & 35 init_transfert, & 36 init_message=>init_message_seq, & 37 finalize_message => finalize_message_seq, & 38 send_message => send_message_seq, & 39 wait_message => wait_message_seq, & 40 test_message => test_message_seq 41 #endif 42 use transfert_mpi_collectives_mod, only : gather_field, scatter_field, bcast_field, bcast_mpi 43 use transfert_omp_mod, only : bcast_omp 44 45 implicit none 46 private 47 public :: t_message, t_request, & 48 req_i1, req_e1_scal, req_e1_vect, & 49 req_i0, req_e0_scal, req_e0_vect, & 50 !req_z1_scal, & 51 init_transfert, & 52 init_message, & 53 finalize_message, & 54 send_message, & 55 wait_message, & 56 test_message, & 57 transfert_request, & 58 transfert_message, & 59 gather_field, scatter_field, bcast_field, bcast, bcast_omp 60 61 interface bcast 62 module procedure bcast_c, & 63 bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & 64 bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & 65 bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 66 end interface 67 68 contains 69 subroutine transfert_message(field, message) 70 use field_mod, only : t_field 71 type(t_field), pointer :: field(:) 72 type(t_message) :: message 73 74 call send_message(field, message) 75 call wait_message(message) 76 end subroutine 77 78 subroutine transfert_request(field, request) 79 use field_mod, only : t_field 80 type(t_field),pointer :: field(:) 81 type(t_request),pointer :: request(:) 82 type(t_message), save :: message ! Save because shared between threads 83 84 call init_message(field, request, message) 85 call transfert_message(field, message) 86 call finalize_message(message) 87 end subroutine 37 88 38 89 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 40 91 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 41 92 42 !! -- Les chaine de charact ère -- !!93 !! -- Les chaine de charactï¿œre -- !! 43 94 44 95 SUBROUTINE bcast_c(var) -
codes/icosagcm/trunk/src/parallel/transfert_mpi.f90
r962 r963 1 MODULE transfert_mpi_mod 2 USE genmod 3 USE field_mod 4 IMPLICIT NONE 5 6 TYPE array 7 INTEGER,POINTER :: value(:)=>null() 8 INTEGER,POINTER :: sign(:)=>null() 9 INTEGER :: domain 10 INTEGER :: rank 11 INTEGER :: tag 12 INTEGER :: size 13 INTEGER :: offset 14 INTEGER :: ireq 15 INTEGER,POINTER :: buffer(:)=>null() 16 REAL,POINTER :: buffer_r(:)=>null() 17 INTEGER,POINTER :: src_value(:)=>null() 18 END TYPE array 19 20 TYPE t_buffer 21 REAL,POINTER :: r(:) 22 INTEGER :: size 23 INTEGER :: rank 24 END TYPE t_buffer 25 26 TYPE t_request 27 INTEGER :: type_field 28 INTEGER :: max_size 29 INTEGER :: size 30 LOGICAL :: vector 31 INTEGER,POINTER :: src_domain(:) 32 INTEGER,POINTER :: src_i(:) 33 INTEGER,POINTER :: src_j(:) 34 INTEGER,POINTER :: src_ind(:) 35 INTEGER,POINTER :: target_ind(:) 36 INTEGER,POINTER :: target_i(:) 37 INTEGER,POINTER :: target_j(:) 38 INTEGER,POINTER :: target_sign(:) 39 INTEGER :: nrecv 40 TYPE(ARRAY),POINTER :: recv(:) 41 INTEGER :: nsend 42 INTEGER :: nreq_mpi 43 INTEGER :: nreq_send 44 INTEGER :: nreq_recv 45 TYPE(ARRAY),POINTER :: send(:) 46 END TYPE t_request 47 48 TYPE(t_request),SAVE,POINTER :: req_i1(:) 49 TYPE(t_request),SAVE,POINTER :: req_e1_scal(:) 50 TYPE(t_request),SAVE,POINTER :: req_e1_vect(:) 51 TYPE(t_request),SAVE,POINTER :: req_z1_scal(:) 52 53 TYPE(t_request),SAVE,POINTER :: req_i0(:) 54 TYPE(t_request),SAVE,POINTER :: req_e0_scal(:) 55 TYPE(t_request),SAVE,POINTER :: req_e0_vect(:) 56 57 TYPE t_reorder 58 INTEGER :: ind 59 INTEGER :: rank 60 INTEGER :: tag 61 INTEGER :: isend 62 END TYPE t_reorder 63 64 TYPE t_message 65 CHARACTER(LEN=100) :: name ! for debug 66 TYPE(t_request), POINTER :: request(:) 67 INTEGER :: nreq 68 INTEGER :: nreq_send 69 INTEGER :: nreq_recv 70 TYPE(t_reorder), POINTER :: reorder(:) 71 INTEGER, POINTER :: mpi_req(:) 72 INTEGER, POINTER :: status(:,:) 73 TYPE(t_buffer),POINTER :: buffers(:) 74 TYPE(t_field),POINTER :: field(:) 75 LOGICAL :: completed 76 LOGICAL :: pending 77 LOGICAL :: open ! for debug 78 INTEGER :: number 79 LOGICAL :: ondevice=.false. !<Ready to transfer ondevice field 80 END TYPE t_message 81 82 83 INTERFACE bcast_mpi 84 MODULE PROCEDURE bcast_mpi_c, & 85 bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & 86 bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & 87 bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 88 END INTERFACE 89 90 integer :: profile_mpi_copies, profile_mpi_waitall, profile_mpi_omp_barrier 91 92 CONTAINS 93 94 95 SUBROUTINE init_transfert 96 USE profiling_mod 97 USE domain_mod 98 USE dimensions 99 USE field_mod 100 USE metric 101 USE mpipara 102 USE mpi_mod 103 IMPLICIT NONE 104 INTEGER :: ind,i,j 105 106 CALL register_id('MPI', id_mpi) 107 CALL register_id('MPI_copies', profile_mpi_copies) 108 CALL register_id('MPI_waitall', profile_mpi_waitall) 109 CALL register_id('MPI_omp_barrier', profile_mpi_omp_barrier) 110 111 CALL create_request(field_t,req_i1) 112 113 DO ind=1,ndomain 114 CALL swap_dimensions(ind) 115 DO i=ii_begin,ii_end+1 116 CALL request_add_point(ind,i,jj_begin-1,req_i1) 117 ENDDO 118 119 DO j=jj_begin,jj_end 120 CALL request_add_point(ind,ii_end+1,j,req_i1) 121 ENDDO 122 DO i=ii_begin,ii_end 123 CALL request_add_point(ind,i,jj_end+1,req_i1) 124 ENDDO 125 126 DO j=jj_begin,jj_end+1 127 CALL request_add_point(ind,ii_begin-1,j,req_i1) 128 ENDDO 129 130 ENDDO 131 132 CALL finalize_request(req_i1) 133 134 135 CALL create_request(field_t,req_i0) 136 137 DO ind=1,ndomain 138 CALL swap_dimensions(ind) 139 140 DO i=ii_begin,ii_end 141 CALL request_add_point(ind,i,jj_begin,req_i0) 142 ENDDO 143 144 DO j=jj_begin,jj_end 145 CALL request_add_point(ind,ii_end,j,req_i0) 146 ENDDO 147 148 DO i=ii_begin,ii_end 149 CALL request_add_point(ind,i,jj_end,req_i0) 150 ENDDO 151 152 DO j=jj_begin,jj_end 153 CALL request_add_point(ind,ii_begin,j,req_i0) 154 ENDDO 155 156 ENDDO 157 158 CALL finalize_request(req_i0) 159 160 161 CALL create_request(field_u,req_e1_scal) 162 DO ind=1,ndomain 163 CALL swap_dimensions(ind) 164 DO i=ii_begin,ii_end 165 CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup) 166 CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup) 167 ENDDO 168 169 DO j=jj_begin,jj_end 170 CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left) 171 ENDDO 172 DO j=jj_begin,jj_end 173 CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup) 174 ENDDO 175 176 DO i=ii_begin,ii_end 177 CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown) 178 CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown) 179 ENDDO 180 181 DO j=jj_begin,jj_end 182 CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right) 183 ENDDO 184 DO j=jj_begin,jj_end 185 CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown) 186 ENDDO 187 188 ENDDO 189 190 CALL finalize_request(req_e1_scal) 191 192 193 CALL create_request(field_u,req_e0_scal) 194 DO ind=1,ndomain 195 CALL swap_dimensions(ind) 196 197 198 DO i=ii_begin+1,ii_end-1 199 CALL request_add_point(ind,i,jj_begin,req_e0_scal,right) 200 CALL request_add_point(ind,i,jj_end,req_e0_scal,right) 201 ENDDO 202 203 DO j=jj_begin+1,jj_end-1 204 CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup) 205 CALL request_add_point(ind,ii_end,j,req_e0_scal,rup) 206 ENDDO 207 208 CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left) 209 CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown) 210 CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left) 211 CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown) 212 213 ENDDO 214 215 CALL finalize_request(req_e0_scal) 216 217 218 219 CALL create_request(field_u,req_e1_vect,.TRUE.) 220 DO ind=1,ndomain 221 CALL swap_dimensions(ind) 222 DO i=ii_begin,ii_end 223 CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup) 224 CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup) 225 ENDDO 226 227 DO j=jj_begin,jj_end 228 CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left) 229 ENDDO 230 DO j=jj_begin,jj_end 231 CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup) 232 ENDDO 233 234 DO i=ii_begin,ii_end 235 CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown) 236 CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown) 237 ENDDO 238 239 DO j=jj_begin,jj_end 240 CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right) 241 ENDDO 242 DO j=jj_begin,jj_end 243 CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown) 244 ENDDO 245 246 247 ENDDO 248 249 CALL finalize_request(req_e1_vect) 250 251 252 CALL create_request(field_u,req_e0_vect,.TRUE.) 253 DO ind=1,ndomain 254 CALL swap_dimensions(ind) 255 256 DO i=ii_begin+1,ii_end-1 257 CALL request_add_point(ind,i,jj_begin,req_e0_vect,right) 258 CALL request_add_point(ind,i,jj_end,req_e0_vect,right) 259 ENDDO 260 261 DO j=jj_begin+1,jj_end-1 262 CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup) 263 CALL request_add_point(ind,ii_end,j,req_e0_vect,rup) 264 ENDDO 265 266 CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left) 267 CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown) 268 CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left) 269 CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown) 270 271 ENDDO 272 273 CALL finalize_request(req_e0_vect) 274 275 CALL create_request(field_z,req_z1_scal) 276 DO ind=1,ndomain 277 CALL swap_dimensions(ind) 278 DO i=ii_begin,ii_end 279 CALL request_add_point(ind,i,jj_begin-1,req_z1_scal,vrup) 280 CALL request_add_point(ind,i+1,jj_begin-1,req_z1_scal,vup) 281 ENDDO 282 283 DO j=jj_begin,jj_end 284 CALL request_add_point(ind,ii_end+1,j,req_z1_scal,vlup) 285 ENDDO 286 DO j=jj_begin,jj_end 287 CALL request_add_point(ind,ii_end+1,j-1,req_z1_scal,vup) 288 ENDDO 289 290 DO i=ii_begin,ii_end 291 CALL request_add_point(ind,i,jj_end+1,req_z1_scal,vdown) 292 CALL request_add_point(ind,i-1,jj_end+1,req_z1_scal,vrdown) 293 ENDDO 294 295 DO j=jj_begin,jj_end 296 CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrup) 297 ENDDO 298 DO j=jj_begin,jj_end 299 CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrdown) 300 ENDDO 301 302 ENDDO 303 304 CALL finalize_request(req_z1_scal) 305 306 END SUBROUTINE init_transfert 307 308 SUBROUTINE create_request(type_field,request,vector) 309 USE domain_mod 310 USE field_mod 311 IMPLICIT NONE 312 INTEGER :: type_field 313 TYPE(t_request),POINTER :: request(:) 314 LOGICAL,OPTIONAL :: vector 315 316 TYPE(t_request),POINTER :: req 317 TYPE(t_domain),POINTER :: d 318 INTEGER :: ind 319 INTEGER :: max_size 320 321 ALLOCATE(request(ndomain)) 322 323 DO ind=1,ndomain 324 req=>request(ind) 325 d=>domain(ind) 326 IF (type_field==field_t) THEN 327 Max_size=2*(d%iim+2)+2*(d%jjm+2) 328 ELSE IF (type_field==field_u) THEN 329 Max_size=3*(2*(d%iim+2)+2*(d%jjm+2)) 330 ELSE IF (type_field==field_z) THEN 331 Max_size=2*(2*(d%iim+2)+2*(d%jjm+2)) 332 ENDIF 333 334 req%type_field=type_field 335 req%max_size=max_size*2 336 req%size=0 337 req%vector=.FALSE. 338 IF (PRESENT(vector)) req%vector=vector 339 ALLOCATE(req%src_domain(req%max_size)) 340 ALLOCATE(req%src_ind(req%max_size)) 341 ALLOCATE(req%target_ind(req%max_size)) 342 ALLOCATE(req%src_i(req%max_size)) 343 ALLOCATE(req%src_j(req%max_size)) 344 ALLOCATE(req%target_i(req%max_size)) 345 ALLOCATE(req%target_j(req%max_size)) 346 ALLOCATE(req%target_sign(req%max_size)) 347 ENDDO 348 349 END SUBROUTINE create_request 350 351 SUBROUTINE reallocate_request(req) 352 IMPLICIT NONE 353 TYPE(t_request),POINTER :: req 354 355 INTEGER,POINTER :: src_domain(:) 356 INTEGER,POINTER :: src_ind(:) 357 INTEGER,POINTER :: target_ind(:) 358 INTEGER,POINTER :: src_i(:) 359 INTEGER,POINTER :: src_j(:) 360 INTEGER,POINTER :: target_i(:) 361 INTEGER,POINTER :: target_j(:) 362 INTEGER,POINTER :: target_sign(:) 363 364 PRINT *,"REALLOCATE_REQUEST" 365 src_domain=>req%src_domain 366 src_ind=>req%src_ind 367 target_ind=>req%target_ind 368 src_i=>req%src_i 369 src_j=>req%src_j 370 target_i=>req%target_i 371 target_j=>req%target_j 372 target_sign=>req%target_sign 373 374 ALLOCATE(req%src_domain(req%max_size*2)) 375 ALLOCATE(req%src_ind(req%max_size*2)) 376 ALLOCATE(req%target_ind(req%max_size*2)) 377 ALLOCATE(req%src_i(req%max_size*2)) 378 ALLOCATE(req%src_j(req%max_size*2)) 379 ALLOCATE(req%target_i(req%max_size*2)) 380 ALLOCATE(req%target_j(req%max_size*2)) 381 ALLOCATE(req%target_sign(req%max_size*2)) 382 383 req%src_domain(1:req%max_size)=src_domain(:) 384 req%src_ind(1:req%max_size)=src_ind(:) 385 req%target_ind(1:req%max_size)=target_ind(:) 386 req%src_i(1:req%max_size)=src_i(:) 387 req%src_j(1:req%max_size)=src_j(:) 388 req%target_i(1:req%max_size)=target_i(:) 389 req%target_j(1:req%max_size)=target_j(:) 390 req%target_sign(1:req%max_size)=target_sign(:) 391 392 req%max_size=req%max_size*2 393 394 DEALLOCATE(src_domain) 395 DEALLOCATE(src_ind) 396 DEALLOCATE(target_ind) 397 DEALLOCATE(src_i) 398 DEALLOCATE(src_j) 399 DEALLOCATE(target_i) 400 DEALLOCATE(target_j) 401 DEALLOCATE(target_sign) 402 403 END SUBROUTINE reallocate_request 404 405 406 SUBROUTINE request_add_point(ind,i,j,request,pos) 407 USE domain_mod 408 USE field_mod 409 IMPLICIT NONE 410 INTEGER,INTENT(IN) :: ind 411 INTEGER,INTENT(IN) :: i 412 INTEGER,INTENT(IN) :: j 413 TYPE(t_request),POINTER :: request(:) 414 INTEGER,INTENT(IN),OPTIONAL :: pos 415 416 INTEGER :: src_domain 417 INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta 418 TYPE(t_request),POINTER :: req 419 TYPE(t_domain),POINTER :: d 420 421 req=>request(ind) 422 d=>domain(ind) 423 424 IF (req%max_size==req%size) CALL reallocate_request(req) 425 req%size=req%size+1 426 IF (req%type_field==field_t) THEN 427 src_domain=domain(ind)%assign_domain(i,j) 428 src_iim=domain_glo(src_domain)%iim 429 src_i=domain(ind)%assign_i(i,j) 430 src_j=domain(ind)%assign_j(i,j) 431 432 req%target_ind(req%size)=(j-1)*d%iim+i 433 req%target_sign(req%size)=1 434 req%src_domain(req%size)=src_domain 435 req%src_ind(req%size)=(src_j-1)*src_iim+src_i 436 ELSE IF (req%type_field==field_u) THEN 437 IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme' 438 439 src_domain=domain(ind)%edge_assign_domain(pos-1,i,j) 440 src_iim=domain_glo(src_domain)%iim 441 src_i=domain(ind)%edge_assign_i(pos-1,i,j) 442 src_j=domain(ind)%edge_assign_j(pos-1,i,j) 443 src_n=(src_j-1)*src_iim+src_i 444 src_delta=domain(ind)%delta(i,j) 445 src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1 446 447 req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos) 448 449 req%target_sign(req%size)= 1 450 IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j) 451 452 req%src_domain(req%size)=src_domain 453 req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos) 454 455 ELSE IF (req%type_field==field_z) THEN 456 IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme' 457 458 src_domain=domain(ind)%vertex_assign_domain(pos-1,i,j) 459 src_iim=domain_glo(src_domain)%iim 460 src_i=domain(ind)%vertex_assign_i(pos-1,i,j) 461 src_j=domain(ind)%vertex_assign_j(pos-1,i,j) 462 src_n=(src_j-1)*src_iim+src_i 463 src_delta=domain(ind)%delta(i,j) 464 src_pos=domain(ind)%vertex_assign_pos(pos-1,i,j)+1 465 466 467 req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos) 468 req%target_sign(req%size)=1 469 req%src_domain(req%size)=src_domain 470 req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos) 471 ENDIF 472 END SUBROUTINE request_add_point 473 474 475 SUBROUTINE Finalize_request(request) 476 USE mpipara 477 USE domain_mod 478 USE mpi_mod 479 IMPLICIT NONE 480 TYPE(t_request),POINTER :: request(:) 481 TYPE(t_request),POINTER :: req, req_src 482 INTEGER :: nb_domain_recv(0:mpi_size-1) 483 INTEGER :: nb_domain_send(0:mpi_size-1) 484 INTEGER :: tag_rank(0:mpi_size-1) 485 INTEGER :: nb_data_domain_recv(ndomain_glo) 486 INTEGER :: list_domain_recv(ndomain_glo) 487 INTEGER,ALLOCATABLE :: list_domain_send(:) 488 INTEGER :: list_domain(ndomain) 489 490 INTEGER :: rank,i,j,pos 491 INTEGER :: size_,ind_glo,ind_loc 492 INTEGER :: isend, irecv, ireq, nreq, nsend, nrecv 493 INTEGER, ALLOCATABLE :: mpi_req(:) 494 INTEGER, ALLOCATABLE :: status(:,:) 495 INTEGER, ALLOCATABLE :: rank_list(:) 496 INTEGER, ALLOCATABLE :: offset(:) 497 LOGICAL,PARAMETER :: debug = .FALSE. 498 499 500 IF (.NOT. using_mpi) RETURN 501 502 DO ind_loc=1,ndomain 503 req=>request(ind_loc) 504 505 nb_data_domain_recv(:) = 0 506 nb_domain_recv(:) = 0 507 tag_rank(:)=0 508 509 DO i=1,req%size 510 ind_glo=req%src_domain(i) 511 nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1 512 ENDDO 513 514 DO ind_glo=1,ndomain_glo 515 IF ( nb_data_domain_recv(ind_glo) > 0 ) nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1 516 ENDDO 517 518 req%nrecv=sum(nb_domain_recv(:)) 519 ALLOCATE(req%recv(req%nrecv)) 520 521 irecv=0 522 DO ind_glo=1,ndomain_glo 523 IF (nb_data_domain_recv(ind_glo)>0) THEN 524 irecv=irecv+1 525 list_domain_recv(ind_glo)=irecv 526 req%recv(irecv)%rank=domglo_rank(ind_glo) 527 req%recv(irecv)%size=nb_data_domain_recv(ind_glo) 528 req%recv(irecv)%domain=domglo_loc_ind(ind_glo) 529 ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size)) 530 ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size)) 531 ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size)) 532 ENDIF 533 ENDDO 534 535 req%recv(:)%size=0 536 irecv=0 537 DO i=1,req%size 538 irecv=list_domain_recv(req%src_domain(i)) 539 req%recv(irecv)%size=req%recv(irecv)%size+1 540 size_=req%recv(irecv)%size 541 req%recv(irecv)%value(size_)=req%src_ind(i) 542 req%recv(irecv)%buffer(size_)=req%target_ind(i) 543 req%recv(irecv)%sign(size_)=req%target_sign(i) 544 ENDDO 545 ENDDO 546 547 nb_domain_recv(:) = 0 548 DO ind_loc=1,ndomain 549 req=>request(ind_loc) 550 551 DO irecv=1,req%nrecv 552 rank=req%recv(irecv)%rank 553 nb_domain_recv(rank)=nb_domain_recv(rank)+1 554 ENDDO 555 ENDDO 556 557 CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr) 558 559 560 ALLOCATE(list_domain_send(sum(nb_domain_send))) 561 562 nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:)) 563 ALLOCATE(mpi_req(nreq)) 564 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 565 566 567 ireq=0 568 DO ind_loc=1,ndomain 569 req=>request(ind_loc) 570 DO irecv=1,req%nrecv 571 ireq=ireq+1 572 CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr) 573 IF (debug) PRINT *,"Isend ",req%recv(irecv)%domain, "from ", mpi_rank, "to ",req%recv(irecv)%rank, "tag ",0 574 ENDDO 575 ENDDO 576 577 IF (debug) PRINT *,"------------" 578 j=0 579 DO rank=0,mpi_size-1 580 DO i=1,nb_domain_send(rank) 581 j=j+1 582 ireq=ireq+1 583 CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr) 584 IF (debug) PRINT *,"IRecv ",list_domain_send(j), "from ", rank, "to ",mpi_rank, "tag ",0 585 ENDDO 586 ENDDO 587 IF (debug) PRINT *,"------------" 588 589 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 590 591 list_domain(:)=0 592 DO i=1,sum(nb_domain_send) 593 ind_loc=list_domain_send(i) 594 list_domain(ind_loc)=list_domain(ind_loc)+1 595 ENDDO 596 597 DO ind_loc=1,ndomain 598 req=>request(ind_loc) 599 req%nsend=list_domain(ind_loc) 600 ALLOCATE(req%send(req%nsend)) 601 ENDDO 602 603 IF (debug) PRINT *,"------------" 604 605 ireq=0 606 DO ind_loc=1,ndomain 607 req=>request(ind_loc) 608 609 DO irecv=1,req%nrecv 610 ireq=ireq+1 611 CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 612 IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 613 ENDDO 614 IF (debug) PRINT *,"------------" 615 616 DO isend=1,req%nsend 617 ireq=ireq+1 618 CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr) 619 IF (debug) PRINT *,"IRecv ",req%send(isend)%rank, "from ", "xxx", "to ",mpi_rank, "tag ",ind_loc 620 ENDDO 621 ENDDO 622 623 IF (debug) PRINT *,"------------" 624 625 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 626 CALL MPI_BARRIER(comm_icosa,ierr) 627 628 IF (debug) PRINT *,"------------" 629 630 ireq=0 631 DO ind_loc=1,ndomain 632 req=>request(ind_loc) 633 634 DO irecv=1,req%nrecv 635 ireq=ireq+1 636 CALL MPI_ISEND(ind_loc,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 637 IF (debug) PRINT *,"Isend ",ind_loc, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 638 ENDDO 639 640 IF (debug) PRINT *,"------------" 641 642 DO isend=1,req%nsend 643 ireq=ireq+1 644 CALL MPI_IRECV(req%send(isend)%domain,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 645 IF (debug) PRINT *,"IRecv ",req%send(isend)%domain, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 646 ENDDO 647 ENDDO 648 IF (debug) PRINT *,"------------" 649 650 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 651 CALL MPI_BARRIER(comm_icosa,ierr) 652 IF (debug) PRINT *,"------------" 653 654 ireq=0 655 DO ind_loc=1,ndomain 656 req=>request(ind_loc) 657 658 DO irecv=1,req%nrecv 659 ireq=ireq+1 660 req%recv(irecv)%tag=tag_rank(req%recv(irecv)%rank) 661 tag_rank(req%recv(irecv)%rank)=tag_rank(req%recv(irecv)%rank)+1 662 CALL MPI_ISEND(req%recv(irecv)%tag,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 663 IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 664 ENDDO 665 IF (debug) PRINT *,"------------" 666 667 DO isend=1,req%nsend 668 ireq=ireq+1 669 CALL MPI_IRECV(req%send(isend)%tag,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 670 IF (debug) PRINT *,"IRecv ",req%send(isend)%tag, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 671 ENDDO 672 ENDDO 673 IF (debug) PRINT *,"------------" 674 675 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 676 CALL MPI_BARRIER(comm_icosa,ierr) 677 678 679 IF (debug) PRINT *,"------------" 680 681 ireq=0 682 DO ind_loc=1,ndomain 683 req=>request(ind_loc) 684 685 DO irecv=1,req%nrecv 686 ireq=ireq+1 687 CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 688 IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 689 ENDDO 690 IF (debug) PRINT *,"------------" 691 692 DO isend=1,req%nsend 693 ireq=ireq+1 694 CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 695 IF (debug) PRINT *,"IRecv ",req%send(isend)%size, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 696 ENDDO 697 ENDDO 698 699 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 700 701 ireq=0 702 DO ind_loc=1,ndomain 703 req=>request(ind_loc) 704 705 DO irecv=1,req%nrecv 706 ireq=ireq+1 707 CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,& 708 req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 709 ENDDO 710 711 DO isend=1,req%nsend 712 ireq=ireq+1 713 ALLOCATE(req%send(isend)%value(req%send(isend)%size)) 714 CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,& 715 req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 716 ENDDO 717 ENDDO 718 719 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 720 721 DO ind_loc=1,ndomain 722 req=>request(ind_loc) 723 724 DO irecv=1,req%nrecv 725 req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:) 726 req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:) 727 DEALLOCATE(req%recv(irecv)%buffer) 728 ENDDO 729 ENDDO 730 731 732 ! domain is on the same mpi process => copie memory to memory 733 734 DO ind_loc=1,ndomain 735 req=>request(ind_loc) 736 737 DO irecv=1,req%nrecv 738 739 IF (req%recv(irecv)%rank==mpi_rank) THEN 740 req_src=>request(req%recv(irecv)%domain) 741 DO isend=1,req_src%nsend 742 IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%tag==req%recv(irecv)%tag) THEN 743 req%recv(irecv)%src_value => req_src%send(isend)%value 744 IF ( size(req%recv(irecv)%value) /= size(req_src%send(isend)%value)) THEN 745 PRINT *,ind_loc, irecv, isend, size(req%recv(irecv)%value), size(req_src%send(isend)%value) 746 STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value" 747 ENDIF 748 ENDIF 749 ENDDO 750 ENDIF 751 752 ENDDO 753 ENDDO 754 755 ! true number of mpi request 756 757 request(:)%nreq_mpi=0 758 request(:)%nreq_send=0 759 request(:)%nreq_recv=0 760 ALLOCATE(rank_list(sum(request(:)%nsend))) 761 ALLOCATE(offset(sum(request(:)%nsend))) 762 offset(:)=0 763 764 nsend=0 765 DO ind_loc=1,ndomain 766 req=>request(ind_loc) 767 768 DO isend=1,req%nsend 769 IF (req%send(isend)%rank/=mpi_rank) THEN 770 pos=0 771 DO i=1,nsend 772 IF (req%send(isend)%rank==rank_list(i)) EXIT 773 pos=pos+1 774 ENDDO 775 776 IF (pos==nsend) THEN 777 nsend=nsend+1 778 req%nreq_mpi=req%nreq_mpi+1 779 req%nreq_send=req%nreq_send+1 780 IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 781 rank_list(nsend)=req%send(isend)%rank 782 ELSE 783 rank_list(nsend)=-1 784 ENDIF 785 ENDIF 786 787 pos=pos+1 788 req%send(isend)%ireq=pos 789 req%send(isend)%offset=offset(pos) 790 offset(pos)=offset(pos)+req%send(isend)%size 791 ENDIF 792 ENDDO 793 ENDDO 794 795 DEALLOCATE(rank_list) 796 DEALLOCATE(offset) 797 798 ALLOCATE(rank_list(sum(request(:)%nrecv))) 799 ALLOCATE(offset(sum(request(:)%nrecv))) 800 offset(:)=0 801 802 nrecv=0 803 DO ind_loc=1,ndomain 804 req=>request(ind_loc) 805 806 DO irecv=1,req%nrecv 807 IF (req%recv(irecv)%rank/=mpi_rank) THEN 808 pos=0 809 DO i=1,nrecv 810 IF (req%recv(irecv)%rank==rank_list(i)) EXIT 811 pos=pos+1 812 ENDDO 813 814 IF (pos==nrecv) THEN 815 nrecv=nrecv+1 816 req%nreq_mpi=req%nreq_mpi+1 817 req%nreq_recv=req%nreq_recv+1 818 IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 819 rank_list(nrecv)=req%recv(irecv)%rank 820 ELSE 821 rank_list(nrecv)=-1 822 ENDIF 823 ENDIF 824 825 pos=pos+1 826 req%recv(irecv)%ireq=nsend+pos 827 req%recv(irecv)%offset=offset(pos) 828 offset(pos)=offset(pos)+req%recv(irecv)%size 829 ENDIF 830 ENDDO 831 ENDDO 832 833 ! get the offsets 834 835 ireq=0 836 DO ind_loc=1,ndomain 837 req=>request(ind_loc) 838 839 DO irecv=1,req%nrecv 840 ireq=ireq+1 841 CALL MPI_ISEND(req%recv(irecv)%offset,1,MPI_INTEGER,& 842 req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 843 ENDDO 844 845 DO isend=1,req%nsend 846 ireq=ireq+1 847 CALL MPI_IRECV(req%send(isend)%offset,1,MPI_INTEGER,& 848 req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 849 ENDDO 850 ENDDO 851 852 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 853 854 855 END SUBROUTINE Finalize_request 856 857 858 SUBROUTINE init_message_seq(field, request, message, name) 859 USE field_mod 860 USE domain_mod 861 USE mpi_mod 862 USE mpipara 863 USE mpi_mod 864 IMPLICIT NONE 865 TYPE(t_field),POINTER :: field(:) 866 TYPE(t_request),POINTER :: request(:) 867 TYPE(t_message) :: message 868 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name 869 !$OMP MASTER 870 message%request=>request 871 IF(PRESENT(name)) THEN 872 message%name = TRIM(name) 873 ELSE 874 message%name = 'unknown' 875 END IF 876 !$OMP END MASTER 877 !$OMP BARRIER 878 879 END SUBROUTINE init_message_seq 880 881 SUBROUTINE send_message_seq(field,message) 882 USE field_mod 883 USE domain_mod 884 USE mpi_mod 885 USE mpipara 886 USE omp_para 887 USE trace 888 IMPLICIT NONE 889 TYPE(t_field),POINTER :: field(:) 890 TYPE(t_message) :: message 891 892 CALL transfert_request_seq(field,message%request) 893 894 END SUBROUTINE send_message_seq 895 896 SUBROUTINE test_message_seq(message) 897 IMPLICIT NONE 898 TYPE(t_message) :: message 899 END SUBROUTINE test_message_seq 900 901 902 SUBROUTINE wait_message_seq(message) 903 IMPLICIT NONE 904 TYPE(t_message) :: message 905 906 END SUBROUTINE wait_message_seq 907 908 SUBROUTINE transfert_message_seq(field,message) 909 USE field_mod 910 USE domain_mod 911 USE mpi_mod 912 USE mpipara 913 USE omp_para 914 USE trace 915 IMPLICIT NONE 916 TYPE(t_field),POINTER :: field(:) 917 TYPE(t_message) :: message 918 919 CALL send_message_seq(field,message) 920 921 END SUBROUTINE transfert_message_seq 922 923 924 925 926 SUBROUTINE init_message_mpi(field,request, message, name) 927 USE field_mod 928 USE domain_mod 929 USE mpi_mod 930 USE mpipara 931 USE mpi_mod 932 IMPLICIT NONE 933 934 TYPE(t_field),POINTER :: field(:) 935 TYPE(t_request),POINTER :: request(:) 936 TYPE(t_message) :: message 937 CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: name 938 939 TYPE(t_request),POINTER :: req 940 INTEGER :: irecv,isend 941 INTEGER :: ireq,nreq 942 INTEGER :: ind 943 INTEGER :: dim3,dim4 944 INTEGER,SAVE :: message_number=0 945 ! TYPE(t_reorder),POINTER :: reorder(:) 946 ! TYPE(t_reorder) :: reorder_swap 947 948 !$OMP BARRIER 949 !$OMP MASTER 1 ! Module for MPI communication of field halos 2 ! This module uses Fortran 2003 features : move_alloc intrinsic, pointer bounds remapping, allocatable type fields 3 module transfert_mpi_mod 4 use abort_mod, only : dynamico_abort, abort_acc 5 use profiling_mod, only : enter_profile, exit_profile, register_id 6 use domain_mod, only : ndomain, ndomain_glo, domain, domain_glo, domloc_glo_ind, domglo_rank, domglo_loc_ind 7 use field_mod, only : t_field, field_T, field_U 8 use transfert_request_mod 9 implicit none 10 private 11 12 ! Describes how to pack/unpack a message from a local domain to another 13 type t_local_submessage 14 integer :: src_ind_loc, dest_ind_loc ! index of local and remote domain 15 integer, allocatable :: displ_src(:) ! List of indexes to copy from domain src_ind_loc 16 integer, allocatable :: displ_dest(:) ! List of indexes to copy to domain dest_ind_loc 17 integer, allocatable :: sign(:) ! Sign change to be applied for vector requests 18 end type 19 20 ! Describes how to pack/unpack a message from a domain to another, and contains MPI buffer 21 type t_submessage 22 integer :: ind_loc, remote_ind_glo ! index of local and remote domain 23 integer, allocatable :: displs(:) ! List of indexes to copy from field to buffer for each level 24 integer, allocatable :: sign(:) ! Sign change to be applied for vector requests 25 real, allocatable :: buff(:,:,:) ! MPI buffer buff(iim*jjm[*3],dim3,dim4) 26 end type 27 28 ! Describes how to exchange data for a field. 29 type t_message 30 type (t_field), pointer :: field(:) => null() ! Field to exchange 31 type (t_request), pointer :: request(:) => null() ! Type of message to send 32 type (t_local_submessage), pointer :: message_local(:) ! Local halo copies 33 type (t_submessage), pointer :: message_in(:) ! Messages to recieve from remote ranks and to copy back to the field 34 type (t_submessage), pointer :: message_out(:) ! Halos to copy to MPI buffer and to send to remote ranks 35 integer, pointer :: mpi_requests_in(:) ! MPI requests used for message_in. 36 integer, pointer :: mpi_requests_out(:) ! MPI requests used for message_out. 37 ! NOTE : requests are persistant requests initialized in init_message. MPI_Start and MPI_Wait are then used to initiate and complete communications. 38 ! ex : Give mpi_requests_in(i) to MPI_Start to send the buffer contained in message_in(i) 39 integer :: send_seq ! Sequence number : send_seq is incremented each time send_message is called 40 integer :: wait_seq ! Sequence number : wait_seq is incremented each time wait_message is called 41 logical :: ondevice ! Ready to transfer ondevice field 42 end type t_message 43 44 public :: t_message, t_request, & 45 req_i1, req_e1_scal, req_e1_vect, & 46 req_i0, req_e0_scal, req_e0_vect, & 47 req_z1_scal, & 48 init_transfert, & 49 init_message, & 50 finalize_message, & 51 send_message, & 52 wait_message, & 53 test_message 54 55 ! ---- Private variables ---- 56 ! Profiling id for mpi 57 integer :: profile_mpi, profile_mpi_copies, profile_mpi_waitall, profile_mpi_barrier 58 contains 59 ! Initialize transfert : must be called before any other transfert_mpi routines 60 subroutine init_transfert 61 use mpi_mod, only : MPI_THREAD_SINGLE, MPI_THREAD_FUNNELED 62 use mpipara, only : mpi_threading_mode 63 use profiling_mod, only : register_id 64 logical, parameter :: profile_mpi_detail = .true. 65 66 !$omp master 67 ! Check requested threads support 68 if( mpi_threading_mode /= MPI_THREAD_SINGLE .and. mpi_threading_mode /= MPI_THREAD_FUNNELED ) call dynamico_abort("Only single and funneled threading mode are supported.") 69 70 ! Register profiling ids 71 call register_id("MPI", profile_mpi) 72 if( profile_mpi_detail ) then 73 call register_id("MPI_copies", profile_mpi_copies) 74 call register_id("MPI_waitall", profile_mpi_waitall) 75 call register_id("MPI_omp_barrier", profile_mpi_barrier) 76 else 77 profile_mpi_copies = profile_mpi 78 profile_mpi_waitall = profile_mpi 79 profile_mpi_barrier = profile_mpi 80 endif 81 82 ! Initialize requests 83 call init_all_requests() 84 !$omp end master 85 !$omp barrier 86 end subroutine 87 88 subroutine init_message(field, request, message, name) 89 use mpi_mod 90 use mpipara 91 type(t_field), pointer, intent(in) :: field(:) 92 type(t_request),pointer, intent(in) :: request(:) 93 type(t_message), target, intent(out) :: message ! Needs intent out for call to finalize_message 94 character(len=*), intent(in),optional :: name 95 integer, parameter :: INITIAL_ALLOC_SIZE = 10, GROW_FACTOR = 2 96 97 type(t_submessage) :: submessage_in, submessage_out 98 type(t_local_submessage) :: submessage_local 99 integer :: dim3, dim4 100 integer :: ind, ind_loc, remote_ind_glo, i 101 integer :: message_in_size, message_out_size, message_local_size 102 type(t_local_submessage), allocatable :: message_local_tmp(:) 103 type(t_submessage), allocatable :: message_in_tmp(:), message_out_tmp(:) 104 type(t_submessage), pointer :: submessage 105 106 !$omp barrier 107 !$omp master 950 108 !init off-device 951 109 message%ondevice=.false. 952 953 IF(PRESENT(name)) THEN 954 message%name = TRIM(name) 955 ELSE 956 message%name = 'unknown' 957 END IF 958 message%number=message_number 959 message_number=message_number+1 960 IF (message_number==100) message_number=0 961 962 963 message%request=>request 964 message%nreq=sum(message%request(:)%nreq_mpi) 965 message%nreq_send=sum(message%request(:)%nreq_send) 966 message%nreq_recv=sum(message%request(:)%nreq_recv) 967 nreq=message%nreq 968 969 ALLOCATE(message%mpi_req(nreq)) 970 ALLOCATE(message%buffers(nreq)) 971 ALLOCATE(message%status(MPI_STATUS_SIZE,nreq)) 972 message%buffers(:)%size=0 973 message%pending=.FALSE. 974 message%completed=.FALSE. 975 message%open=.FALSE. 976 977 DO ind=1,ndomain 978 req=>request(ind) 979 DO isend=1,req%nsend 980 IF (req%send(isend)%rank/=mpi_rank) THEN 981 ireq=req%send(isend)%ireq 982 message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size 983 message%buffers(ireq)%rank=req%send(isend)%rank 984 ENDIF 985 ENDDO 986 DO irecv=1,req%nrecv 987 IF (req%recv(irecv)%rank/=mpi_rank) THEN 988 ireq=req%recv(irecv)%ireq 989 message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size 990 message%buffers(ireq)%rank=req%recv(irecv)%rank 991 ENDIF 992 ENDDO 993 ENDDO 994 995 996 IF (field(1)%data_type==type_real) THEN 997 998 IF (field(1)%ndim==2) THEN 999 1000 DO ireq=1,message%nreq 1001 CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 1002 ENDDO 1003 1004 ELSE IF (field(1)%ndim==3) THEN 1005 1006 dim3=size(field(1)%rval3d,2) 1007 DO ireq=1,message%nreq 1008 message%buffers(ireq)%size=message%buffers(ireq)%size*dim3 1009 CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 1010 ENDDO 1011 1012 ELSE IF (field(1)%ndim==4) THEN 1013 dim3=size(field(1)%rval4d,2) 1014 dim4=size(field(1)%rval4d,3) 1015 DO ireq=1,message%nreq 1016 message%buffers(ireq)%size=message%buffers(ireq)%size*dim3*dim4 1017 CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 1018 ENDDO 1019 ENDIF 1020 ENDIF 1021 1022 110 message%send_seq = 0 111 message%wait_seq = 0 112 ! Set field%rval4d pointer to always use 4d array 113 do ind = 1, ndomain 114 if( field(ind)%ndim == 2 ) field(ind)%rval4d(1:size(field(ind)%rval2d,1),1:1,1:1) => field(ind)%rval2d 115 ! This is Fortran 2008 : can be avoided by using a subroutine with rval3d as a 1D dummy argument 116 ! (/!\ : using a subroutine might generate a temporary contiguous array) 117 if( field(ind)%ndim == 3 ) field(ind)%rval4d(1:size(field(ind)%rval3d,1), & 118 1:size(field(ind)%rval3d,2), 1:1) => field(ind)%rval3d 119 end do 120 dim3 = size(field(1)%rval4d,2) 121 dim4 = size(field(1)%rval4d,3) 122 message%field => field 123 message%request => request 124 ! Create list of inbound/outbound/local messages 125 allocate(message_in_tmp(INITIAL_ALLOC_SIZE)) 126 message_in_size=0 127 allocate(message_out_tmp(INITIAL_ALLOC_SIZE)) 128 message_out_size=0 129 allocate(message_local_tmp(INITIAL_ALLOC_SIZE)) 130 message_local_size=0 131 do ind_loc = 1, ndomain 132 do remote_ind_glo = 1, ndomain_glo 133 if( domglo_rank(remote_ind_glo) == mpi_rank ) then ! If sending to local domain 134 if(request(ind_loc)%points_HtoB(remote_ind_glo)%npoints > 0 ) then ! Add only non-empty messages 135 ! Add local message ind_loc -> remote_ind_glo, aggregarting submessage_in and submessage_out into submessage_local 136 submessage_out = make_submessage( request(ind_loc)%points_HtoB(remote_ind_glo), & 137 ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) 138 submessage_in = make_submessage(request(domglo_loc_ind(remote_ind_glo))%points_BtoH(domloc_glo_ind(ind_loc)), & 139 domglo_loc_ind(remote_ind_glo), domloc_glo_ind(ind_loc), dim3, dim4, request(1)%vector) 140 submessage_local%src_ind_loc = ind_loc 141 submessage_local%dest_ind_loc = domglo_loc_ind(remote_ind_glo) 142 submessage_local%displ_src = submessage_out%displs 143 submessage_local%displ_dest = submessage_in%displs 144 submessage_local%sign = submessage_in%sign 145 ! Add to local message list 146 call array_append_local_submessage( message_local_tmp, message_local_size, submessage_local) 147 endif 148 else ! If remote domain 149 ! When data to send to remote_domain, add submessage in message%message_out 150 if( request(ind_loc)%points_HtoB(remote_ind_glo)%npoints > 0 ) then 151 submessage_out = make_submessage( request(ind_loc)%points_HtoB(remote_ind_glo), & 152 ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) 153 call array_append_submessage( message_out_tmp, message_out_size, submessage_out ) 154 end if 155 if( request(ind_loc)%points_BtoH(remote_ind_glo)%npoints > 0 ) then 156 submessage_in = make_submessage( request(ind_loc)%points_BtoH(remote_ind_glo), & 157 ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) 158 call array_append_submessage( message_in_tmp, message_in_size, submessage_in ) 159 end if 160 end if 161 end do 162 end do 163 ! Trim message_xx_tmp and put it in message%message_xx 164 allocate(message%message_in(message_in_size)); message%message_in(:) = message_in_tmp(:message_in_size) 165 allocate(message%message_out(message_out_size)); message%message_out(:) = message_out_tmp(:message_out_size) 166 allocate(message%message_local(message_local_size)); message%message_local(:) = message_local_tmp(:message_local_size) 167 168 ! Create MPI Persistant Send/Recv requests 169 allocate( message%mpi_requests_in(size(message%message_in)) ) 170 allocate( message%mpi_requests_out(size(message%message_out)) ) 171 do i=1, size(message%message_out) 172 submessage => message%message_out(i) 173 call MPI_Send_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 174 submessage%remote_ind_glo+ndomain_glo*domloc_glo_ind(submessage%ind_loc), & 175 comm_icosa, message%mpi_requests_out(i), ierr ) 176 end do 177 do i=1, size(message%message_in) 178 submessage => message%message_in(i) 179 call MPI_Recv_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 180 domloc_glo_ind(submessage%ind_loc)+ndomain_glo*submessage%remote_ind_glo, & 181 comm_icosa, message%mpi_requests_in(i), ierr ) 182 end do 183 !$omp end master 184 !$omp barrier 185 contains 186 ! Generate submessage from points 187 function make_submessage(points, ind_loc, remote_ind_glo, dim3, dim4, vector) result(submessage) 188 use dimensions, only : swap_dimensions, iim, u_pos 189 type(t_points), intent(in) :: points 190 integer, intent(in) :: ind_loc, remote_ind_glo, dim3, dim4 191 logical, intent(in) :: vector 192 integer :: k 193 type(t_submessage) :: submessage 194 195 call swap_dimensions(ind_loc) 196 submessage%ind_loc = ind_loc 197 submessage%remote_ind_glo = remote_ind_glo 198 allocate( submessage%buff( points%npoints, dim3, dim4 ) ) 199 allocate( submessage%displs( points%npoints ) ) 200 submessage%displs(:) = points%i + (points%j-1)*iim 201 if(allocated(points%edge)) submessage%displs = submessage%displs + u_pos( points%edge ) 202 allocate(submessage%sign( points%npoints )) 203 if( vector ) then 204 submessage%sign(:) = (/( domain(ind_loc)%edge_assign_sign(points%edge(k)-1, points%i(k), points%j(k)) ,k=1,points%npoints)/) 205 else 206 submessage%sign(:) = 1 207 endif 208 end function 209 210 ! Add element to array, and reallocate if necessary 211 subroutine array_append_submessage( a, a_size, elt ) 212 type(t_submessage), allocatable, intent(inout) :: a(:) 213 integer, intent(inout) :: a_size 214 type(t_submessage), intent(in) :: elt 215 type(t_submessage), allocatable :: a_tmp(:) 216 integer, parameter :: GROW_FACTOR = 2 217 218 if( size( a ) <= a_size ) then 219 allocate( a_tmp ( a_size * GROW_FACTOR ) ) 220 a_tmp(1:a_size) = a(1:a_size) 221 call move_alloc(a_tmp, a) 222 end if 223 a_size = a_size + 1 224 a(a_size) = elt; 225 end subroutine 226 ! Add element to array, and reallocate if necessary 227 subroutine array_append_local_submessage( a, a_size, elt ) 228 type(t_local_submessage), allocatable, intent(inout) :: a(:) 229 integer, intent(inout) :: a_size 230 type(t_local_submessage), intent(in) :: elt 231 type(t_local_submessage), allocatable :: a_tmp(:) 232 integer, parameter :: GROW_FACTOR = 2 233 234 if( size( a ) <= a_size ) then 235 allocate( a_tmp ( a_size * GROW_FACTOR ) ) 236 a_tmp(1:a_size) = a(1:a_size) 237 call move_alloc(a_tmp, a) 238 end if 239 a_size = a_size + 1 240 a(a_size) = elt; 241 end subroutine 242 ! Je demande pardon au dieu du copier-coller car j'ai péché 243 end subroutine 244 245 subroutine message_create_ondevice(message) 246 use mpi_mod 247 use mpipara, only : comm_icosa 248 type(t_message), intent(inout) :: message 249 type(t_submessage), pointer :: submessage 250 integer :: i, ierr 251 252 if( message%ondevice ) call dynamico_abort("Message already on device") 253 254 !$acc enter data copyin(message) async 255 !$acc enter data copyin(message%message_in(:)) async 256 do i = 1, size( message%message_in ) 257 !$acc enter data copyin(message%message_in(i)%buff(:,:,:)) async 258 !$acc enter data copyin(message%message_in(i)%displs(:)) async 259 !$acc enter data copyin(message%message_in(i)%sign(:)) async 260 end do 261 !$acc enter data copyin(message%message_out(:)) async 262 do i = 1, size( message%message_out ) 263 !$acc enter data copyin(message%message_out(i)%buff(:,:,:)) async 264 !$acc enter data copyin(message%message_out(i)%displs(:)) async 265 !!$acc enter data copyin(message%message_out(i)%sign(:)) async 266 end do 267 !$acc enter data copyin(message%message_local(:)) async 268 do i = 1, size( message%message_local ) 269 !$acc enter data copyin(message%message_local(i)%displ_src(:)) async 270 !$acc enter data copyin(message%message_local(i)%displ_dest(:)) async 271 !$acc enter data copyin(message%message_local(i)%sign(:)) async 272 end do 273 !$acc enter data copyin(message%field(:)) async 274 do i = 1, ndomain 275 !$acc enter data copyin(message%field(i)%rval4d(:,:,:)) async 276 end do 277 278 do i=1, size(message%message_out) 279 submessage => message%message_out(i) 280 call MPI_Request_free(message%mpi_requests_out(i), ierr) 281 !$acc host_data use_device(submessage%buff) 282 call MPI_Send_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 283 submessage%remote_ind_glo+ndomain_glo*domloc_glo_ind(submessage%ind_loc), & 284 comm_icosa, message%mpi_requests_out(i), ierr ) 285 !$acc end host_data 286 end do 287 do i=1, size(message%message_in) 288 submessage => message%message_in(i) 289 call MPI_Request_free(message%mpi_requests_in(i), ierr) 290 !$acc host_data use_device(submessage%buff) 291 call MPI_Recv_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 292 domloc_glo_ind(submessage%ind_loc)+ndomain_glo*submessage%remote_ind_glo, & 293 comm_icosa, message%mpi_requests_in(i), ierr ) 294 !$acc end host_data 295 end do 296 297 message%ondevice=.true. 298 !!$acc update device(message%ondevice) 299 end subroutine 300 301 subroutine message_delete_ondevice(message) 302 type(t_message), intent(inout) :: message 303 integer :: i 304 305 if( .not. message%ondevice ) call dynamico_abort("Message not on device") 306 307 do i = 1, size( message%message_in ) 308 !$acc exit data delete(message%message_in(i)%buff(:,:,:)) async 309 !$acc exit data delete(message%message_in(i)%displs(:)) async 310 !$acc exit data delete(message%message_in(i)%sign(:)) async 311 end do 312 !$acc exit data delete(message%message_in(:)) async 313 do i = 1, size( message%message_out ) 314 !$acc exit data delete(message%message_out(i)%buff(:,:,:)) async 315 !$acc exit data delete(message%message_out(i)%displs(:)) async 316 !!$acc exit data delete(message%message_out(i)%sign(:)) async 317 end do 318 !$acc exit data delete(message%message_out(:)) async 319 do i = 1, size( message%message_local ) 320 !$acc exit data delete(message%message_local(i)%displ_src(:)) async 321 !$acc exit data delete(message%message_local(i)%displ_dest(:)) async 322 !$acc exit data delete(message%message_local(i)%sign(:)) async 323 end do 324 !$acc exit data delete(message%message_local(:)) async 325 326 do i = 1, ndomain 327 !$acc exit data delete(message%field(i)%rval4d(:,:,:)) async 328 end do 329 !$acc exit data delete(message%field(:)) async 330 !$acc exit data delete(message) async 331 message%ondevice=.false. 332 end subroutine 333 334 subroutine finalize_message(message) 335 type(t_message), intent(inout) :: message 336 integer :: i, ierr 337 338 !$omp barrier 339 !$omp master 340 if(message%send_seq /= message%wait_seq) call dynamico_abort("No matching wait_message before finalization") 341 342 if(message%ondevice) call message_delete_ondevice(message) 343 deallocate(message%message_in) 344 deallocate(message%message_out) 345 deallocate(message%message_local) 346 do i=1, size(message%mpi_requests_in) 347 call MPI_Request_free(message%mpi_requests_in(i), ierr) 348 end do 349 deallocate(message%mpi_requests_in) 350 do i=1, size(message%mpi_requests_out) 351 call MPI_Request_free(message%mpi_requests_out(i), ierr) 352 end do 353 deallocate(message%mpi_requests_out) 354 !$omp end master 355 !$omp barrier 356 end subroutine 357 358 subroutine send_message(field, message) 359 use mpi_mod 360 use domain_mod, only : assigned_domain 361 use omp_para, only : distrib_level 362 type(t_field),pointer :: field(:) 363 type(t_message), target :: message 364 integer :: i, k, d3, d4 365 integer :: ierr, d3_begin, d3_end, dim4 366 367 call enter_profile(profile_mpi) 368 369 ! Needed because rval4d is set in init_message 370 if( .not. associated( message%field, field ) ) & 371 call dynamico_abort("send_message must be called with the same field used in init_message") 372 373 !Prepare 'message' for on-device copies if field is on device 374 !$omp master 375 if( field(1)%ondevice .and. .not. message%ondevice ) call message_create_ondevice(message) 376 if( field(1)%ondevice .neqv. message%ondevice ) call dynamico_abort("send_message : internal device/host memory synchronization error") 377 ! Check if previous message has been waited 378 if(message%send_seq /= message%wait_seq) & 379 call dynamico_abort("No matching wait_message before new send_message") 380 message%send_seq = message%send_seq + 1 381 !$omp end master 1023 382 1024 ! ! Reorder the request, so recv request are done in the same order than send request 1025 1026 ! nreq_send=sum(request(:)%nsend) 1027 ! message%nreq_send=nreq_send 1028 ! ALLOCATE(message%reorder(nreq_send)) 1029 ! reorder=>message%reorder 1030 ! ireq=0 1031 ! DO ind=1,ndomain 1032 ! req=>request(ind) 1033 ! DO isend=1,req%nsend 1034 ! ireq=ireq+1 1035 ! reorder(ireq)%ind=ind 1036 ! reorder(ireq)%isend=isend 1037 ! reorder(ireq)%tag=req%send(isend)%tag 1038 ! ENDDO 1039 ! ENDDO 1040 1041 ! ! do a very very bad sort 1042 ! DO i=1,nreq_send-1 1043 ! DO j=i+1,nreq_send 1044 ! IF (reorder(i)%tag > reorder(j)%tag) THEN 1045 ! reorder_swap=reorder(i) 1046 ! reorder(i)=reorder(j) 1047 ! reorder(j)=reorder_swap 1048 ! ENDIF 1049 ! ENDDO 1050 ! ENDDO 1051 ! PRINT *,"reorder ",reorder(:)%tag 1052 1053 1054 !$OMP END MASTER 1055 !$OMP BARRIER 1056 1057 END SUBROUTINE init_message_mpi 1058 1059 SUBROUTINE Finalize_message_mpi(field,message) 1060 USE field_mod 1061 USE domain_mod 1062 USE mpi_mod 1063 USE mpipara 1064 USE mpi_mod 1065 IMPLICIT NONE 1066 TYPE(t_field),POINTER :: field(:) 1067 TYPE(t_message) :: message 1068 1069 INTEGER :: ireq, ibuff 1070 1071 !$OMP BARRIER 1072 !$OMP MASTER 1073 1074 1075 IF (message%field(1)%data_type==type_real) THEN 1076 DO ireq=1,message%nreq 1077 CALL free_mpi_buffer(message%buffers(ireq)%r) 1078 ENDDO 1079 ENDIF 1080 1081 !deallocate device data if ondevice 1082 if(message%ondevice) then 1083 do ireq=1, ndomain 1084 do ibuff=1,message%request(ireq)%nsend 1085 !$acc exit data delete(message%request(ireq)%send(ibuff)%buffer(:)) 1086 !$acc exit data delete(message%request(ireq)%send(ibuff)%buffer_r(:)) 1087 !$acc exit data delete(message%request(ireq)%send(ibuff)%sign(:)) 1088 !$acc exit data delete(message%request(ireq)%send(ibuff)%src_value(:)) 1089 !$acc exit data delete(message%request(ireq)%send(ibuff)%value(:)) 383 call enter_profile(profile_mpi_barrier) 384 !$omp barrier 385 call exit_profile(profile_mpi_barrier) 386 387 dim4 = size(message%field(1)%rval4d, 3) 388 CALL distrib_level( 1, size(message%field(1)%rval4d, 2), d3_begin, d3_end ) 389 390 call enter_profile(profile_mpi_copies) 391 !$acc data present(message) async if(message%ondevice) 392 393 ! Halo to Buffer : copy outbound message to MPI buffers 394 !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) 395 do i = 1, size( message%message_out ) 396 if( assigned_domain( message%message_out(i)%ind_loc ) ) then 397 !$acc loop collapse(2) 398 do d4 = 1, dim4 399 do d3 = d3_begin, d3_end 400 !$acc loop 401 do k = 1, size(message%message_out(i)%displs) 402 message%message_out(i)%buff(k,d3,d4) = message%field(message%message_out(i)%ind_loc)%rval4d(message%message_out(i)%displs(k),d3, d4) 403 end do 404 end do 1090 405 end do 1091 do ibuff=1,message%request(ireq)%nrecv 1092 !$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer(:)) 1093 !$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer_r(:)) 1094 !$acc exit data delete(message%request(ireq)%recv(ibuff)%sign(:)) 1095 !$acc exit data delete(message%request(ireq)%recv(ibuff)%src_value(:)) 1096 !$acc exit data delete(message%request(ireq)%recv(ibuff)%value(:)) 406 endif 407 end do 408 409 ! Halo to Halo : copy local messages from source field to destination field 410 !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) 411 do i = 1, size( message%message_local ) 412 if( assigned_domain( message%message_local(i)%dest_ind_loc ) ) then 413 !$acc loop collapse(2) 414 do d4 = 1, dim4 415 do d3 = d3_begin, d3_end 416 ! Cannot collapse because size(displ_dest) varies with i 417 !$acc loop vector 418 do k = 1, size(message%message_local(i)%displ_dest) 419 message%field(message%message_local(i)%dest_ind_loc)%rval4d(message%message_local(i)%displ_dest(k),d3,d4) = & 420 message%message_local(i)%sign(k)*message%field(message%message_local(i)%src_ind_loc)%rval4d(message%message_local(i)%displ_src(k),d3,d4) 421 end do 422 end do 1097 423 end do 1098 end do 1099 DO ireq=1,message%nreq 1100 !$acc exit data delete(message%buffers(ireq)%r) 1101 ENDDO 1102 message%ondevice=.false. 424 endif 425 end do 426 427 !$acc end data 428 call exit_profile(profile_mpi_copies) 429 430 431 call enter_profile(profile_mpi_barrier) 432 !$acc wait 433 !$omp barrier 434 call exit_profile(profile_mpi_barrier) 435 436 !$omp master 437 call MPI_Startall( size(message%mpi_requests_out), message%mpi_requests_out, ierr ) 438 call MPI_Startall( size(message%mpi_requests_in), message%mpi_requests_in, ierr ) 439 !$omp end master 440 441 call exit_profile(profile_mpi) 442 end subroutine 443 444 subroutine test_message(message) 445 use mpi_mod 446 type(t_message) :: message 447 integer :: ierr 448 logical :: completed 449 450 !$omp master 451 call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr ) 452 call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr ) 453 !$omp end master 454 end subroutine 455 456 subroutine wait_message(message) 457 use mpi_mod 458 use domain_mod, only : assigned_domain 459 use omp_para, only : distrib_level 460 type(t_message), target :: message 461 integer :: d3_begin, d3_end, dim4 462 integer :: i, ierr, k, d3, d4 463 464 ! Check if message has been sent and not recieved yet 465 ! note : barrier needed between this and send_seq increment, and this and wait_seq increment 466 ! note : watch out for integer overflow a = b+1 doesn't imply a>b 467 if(message%send_seq /= message%wait_seq+1) then 468 print*, "WARNING : wait_message called multiple times for one send_message, skipping" 469 return ! Don't recieve message if already recieved 1103 470 end if 1104 471 1105 DEALLOCATE(message%mpi_req) 1106 DEALLOCATE(message%buffers) 1107 DEALLOCATE(message%status) 1108 1109 !$OMP END MASTER 1110 !$OMP BARRIER 1111 1112 1113 END SUBROUTINE Finalize_message_mpi 1114 1115 1116 1117 SUBROUTINE barrier 1118 USE mpi_mod 1119 USE mpipara 1120 IMPLICIT NONE 1121 1122 CALL MPI_BARRIER(comm_icosa,ierr) 1123 1124 END SUBROUTINE barrier 1125 1126 SUBROUTINE transfert_message_mpi(field,message) 1127 USE field_mod 1128 IMPLICIT NONE 1129 TYPE(t_field),POINTER :: field(:) 1130 TYPE(t_message) :: message 1131 1132 CALL send_message_mpi(field,message) 1133 CALL wait_message_mpi(message) 1134 1135 END SUBROUTINE transfert_message_mpi 1136 1137 1138 !!!Update buffers on device for 'message' 1139 !!! does create_device_message when not already ondevice 1140 SUBROUTINE update_device_message_mpi(message) 1141 USE domain_mod 1142 IMPLICIT NONE 1143 TYPE(t_message), intent(inout) :: message 1144 INTEGER :: ireq, ibuff 1145 1146 !if(.not. message%ondevice) call create_device_message_mpi(message) 1147 1148 do ireq=1, ndomain 1149 do ibuff=1,message%request(ireq)%nsend 1150 !device buffers updated even if pointers not attached : 1151 !non allocated buffers in 'message' must be set to NULL() 1152 !$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer(:)) async 1153 !$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer_r(:)) async 1154 !$acc enter data copyin(message%request(ireq)%send(ibuff)%sign(:)) async 1155 !$acc enter data copyin(message%request(ireq)%send(ibuff)%src_value(:)) async 1156 !$acc enter data copyin(message%request(ireq)%send(ibuff)%value(:)) async 1157 end do 1158 do ibuff=1,message%request(ireq)%nrecv 1159 !$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer(:)) async 1160 !$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer_r(:)) async 1161 !$acc enter data copyin(message%request(ireq)%recv(ibuff)%sign(:)) async 1162 !$acc enter data copyin(message%request(ireq)%recv(ibuff)%src_value(:)) async 1163 !$acc enter data copyin(message%request(ireq)%recv(ibuff)%value(:)) async 1164 end do 1165 end do 1166 DO ireq=1,message%nreq 1167 !$acc enter data copyin(message%buffers(ireq)%r) async 1168 ENDDO 1169 message%ondevice=.true. 1170 END SUBROUTINE 1171 1172 !TODO : add openacc with multiple process 1173 SUBROUTINE send_message_mpi(field,message) 1174 USE abort_mod 1175 USE profiling_mod 1176 USE field_mod 1177 USE domain_mod 1178 USE mpi_mod 1179 USE mpipara 1180 USE omp_para 1181 USE trace 1182 USE abort_mod 1183 IMPLICIT NONE 1184 TYPE(t_field),POINTER :: field(:) 1185 TYPE(t_message) :: message 1186 REAL(rstd),POINTER :: rval2d(:), src_rval2d(:) 1187 REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:) 1188 REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:) 1189 REAL(rstd),POINTER :: buffer_r(:) 1190 INTEGER,POINTER :: value(:) 1191 INTEGER,POINTER :: sgn(:) 1192 TYPE(ARRAY),POINTER :: recv,send 1193 TYPE(t_request),POINTER :: req 1194 INTEGER :: irecv,isend 1195 INTEGER :: ireq 1196 INTEGER :: ind,n 1197 INTEGER :: dim3,dim4,d3,d4 1198 INTEGER,POINTER :: src_value(:) 1199 INTEGER :: offset,msize,moffset,rank 1200 INTEGER :: lbegin, lend 1201 INTEGER :: max_req 1202 1203 ! CALL trace_start("send_message_mpi") 1204 1205 CALL enter_profile(id_mpi) 1206 1207 !Prepare 'message' for on-device copies if field is on device 1208 if( field(1)%ondevice .AND. .NOT. message%ondevice ) call update_device_message_mpi(message) 1209 1210 CALL enter_profile(profile_mpi_omp_barrier) 1211 !$OMP BARRIER 1212 CALL exit_profile(profile_mpi_omp_barrier) 1213 1214 1215 !$OMP MASTER 1216 IF(message%open) THEN 1217 PRINT *, 'send_message_mpi : message ' // TRIM(message%name) // & 1218 ' is still open, no call to wait_message_mpi after last send_message_mpi' 1219 CALL dynamico_abort( "send_message_mpi : message still open" ) 1220 END IF 1221 message%open=.TRUE. ! will be set to .FALSE. by wait_message_mpi 1222 1223 message%field=>field 1224 1225 IF (message%nreq>0) THEN 1226 message%completed=.FALSE. 1227 message%pending=.TRUE. 1228 ELSE 1229 message%completed=.TRUE. 1230 message%pending=.FALSE. 1231 ENDIF 1232 !$OMP END MASTER 1233 CALL enter_profile(profile_mpi_omp_barrier) 1234 !$OMP BARRIER 1235 CALL exit_profile(profile_mpi_omp_barrier) 1236 1237 IF (field(1)%data_type==type_real) THEN 1238 IF (field(1)%ndim==2) THEN 1239 1240 DO ind=1,ndomain 1241 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1242 1243 rval2d=>field(ind)%rval2d 1244 1245 req=>message%request(ind) 1246 DO isend=1,req%nsend 1247 send=>req%send(isend) 1248 value=>send%value 1249 1250 1251 IF (send%rank/=mpi_rank) THEN 1252 ireq=send%ireq 1253 1254 buffer_r=>message%buffers(ireq)%r 1255 offset=send%offset 1256 msize=send%size 1257 call enter_profile(profile_mpi_copies) 1258 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1259 DO n=1,msize 1260 buffer_r(offset+n)=rval2d(value(n)) 1261 ENDDO 1262 call exit_profile(profile_mpi_copies) 1263 1264 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1265 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1266 !$OMP CRITICAL 1267 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, & 1268 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1269 !$OMP END CRITICAL 1270 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1271 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1272 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, & 1273 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1274 ENDIF 1275 1276 ENDIF 1277 ENDDO 1278 ENDDO 1279 1280 DO ind=1,ndomain 1281 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1282 rval2d=>field(ind)%rval2d 1283 req=>message%request(ind) 1284 1285 DO irecv=1,req%nrecv 1286 recv=>req%recv(irecv) 1287 1288 IF (recv%rank==mpi_rank) THEN 1289 1290 value=>recv%value 1291 src_value => recv%src_value 1292 src_rval2d=>field(recv%domain)%rval2d 1293 sgn=>recv%sign 1294 msize=recv%size 1295 call enter_profile(profile_mpi_copies) 1296 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1297 DO n=1,msize 1298 rval2d(value(n))=src_rval2d(src_value(n))*sgn(n) 1299 ENDDO 1300 call exit_profile(profile_mpi_copies) 1301 1302 ELSE 1303 1304 ireq=recv%ireq 1305 buffer_r=>message%buffers(ireq)%r 1306 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1307 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1308 !$OMP CRITICAL 1309 CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, & 1310 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1311 !$OMP END CRITICAL 1312 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1313 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1314 CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, & 1315 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1316 ENDIF 1317 1318 ENDIF 1319 ENDDO 1320 1321 ENDDO 1322 1323 1324 ELSE IF (field(1)%ndim==3) THEN 1325 max_req=0 1326 DO ind=1,ndomain 1327 req=>message%request(ind) 1328 IF (req%nsend>max_req) max_req=req%nsend 1329 ENDDO 1330 1331 DO ind=1,ndomain 1332 IF (.NOT. assigned_domain(ind) ) CYCLE 1333 1334 dim3=size(field(ind)%rval3d,2) 1335 CALL distrib_level(1,dim3, lbegin,lend) 1336 1337 rval3d=>field(ind)%rval3d 1338 req=>message%request(ind) 1339 1340 DO isend=1,req%nsend 1341 send=>req%send(isend) 1342 value=>send%value 1343 1344 IF (send%rank/=mpi_rank) THEN 1345 ireq=send%ireq 1346 buffer_r=>message%buffers(ireq)%r 1347 1348 msize=send%size 1349 moffset=send%offset 1350 call enter_profile(profile_mpi_copies) 1351 1352 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1353 DO d3=lbegin,lend 1354 offset=moffset*dim3 + (d3-1)*msize 1355 !$acc loop 1356 DO n=1,msize 1357 buffer_r(n+offset)=rval3d(value(n),d3) 1358 ENDDO 1359 ENDDO 1360 call exit_profile(profile_mpi_copies) 1361 1362 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1363 CALL enter_profile(profile_mpi_omp_barrier) 1364 !$OMP BARRIER 1365 CALL exit_profile(profile_mpi_omp_barrier) 1366 1367 ENDIF 1368 1369 IF (is_omp_level_master) THEN 1370 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1371 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1372 !$OMP CRITICAL 1373 CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, & 1374 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1375 !$OMP END CRITICAL 1376 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1377 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1378 CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, & 1379 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1380 ENDIF 1381 ENDIF 1382 ELSE 1383 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1384 CALL enter_profile(profile_mpi_omp_barrier) 1385 !$OMP BARRIER 1386 CALL exit_profile(profile_mpi_omp_barrier) 1387 1388 ENDIF 1389 ENDIF 1390 ENDDO 1391 1392 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1393 DO isend=req%nsend+1,max_req 1394 CALL enter_profile(profile_mpi_omp_barrier) 1395 !$OMP BARRIER 1396 CALL exit_profile(profile_mpi_omp_barrier) 1397 1398 ENDDO 1399 ENDIF 1400 1401 ENDDO 1402 1403 DO ind=1,ndomain 1404 IF (.NOT. assigned_domain(ind) ) CYCLE 1405 dim3=size(field(ind)%rval3d,2) 1406 CALL distrib_level(1,dim3, lbegin,lend) 1407 rval3d=>field(ind)%rval3d 1408 req=>message%request(ind) 1409 1410 DO irecv=1,req%nrecv 1411 recv=>req%recv(irecv) 1412 1413 IF (recv%rank==mpi_rank) THEN 1414 value=>recv%value 1415 src_value => recv%src_value 1416 src_rval3d=>field(recv%domain)%rval3d 1417 sgn=>recv%sign 1418 msize=recv%size 1419 1420 call enter_profile(profile_mpi_copies) 1421 CALL trace_start("copy_data") 1422 !$acc parallel loop collapse(2) default(present) async if (field(ind)%ondevice) 1423 DO d3=lbegin,lend 1424 DO n=1,msize 1425 rval3d(value(n),d3)=src_rval3d(src_value(n),d3)*sgn(n) 1426 ENDDO 1427 ENDDO 1428 call exit_profile(profile_mpi_copies) 1429 CALL trace_end("copy_data") 1430 1431 ELSE 1432 ireq=recv%ireq 1433 buffer_r=>message%buffers(ireq)%r 1434 1435 IF (is_omp_level_master) THEN 1436 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1437 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1438 !$OMP CRITICAL 1439 CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank, & 1440 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1441 !$OMP END CRITICAL 1442 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1443 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1444 CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank, & 1445 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1446 ENDIF 1447 ENDIF 1448 ENDIF 1449 ENDDO 1450 1451 ENDDO 1452 1453 ELSE IF (field(1)%ndim==4) THEN 1454 1455 max_req=0 1456 DO ind=1,ndomain 1457 req=>message%request(ind) 1458 IF (req%nsend>max_req) max_req=req%nsend 1459 ENDDO 1460 1461 DO ind=1,ndomain 1462 IF (.NOT. assigned_domain(ind) ) CYCLE 1463 1464 dim3=size(field(ind)%rval4d,2) 1465 CALL distrib_level(1,dim3, lbegin,lend) 1466 dim4=size(field(ind)%rval4d,3) 1467 rval4d=>field(ind)%rval4d 1468 req=>message%request(ind) 1469 1470 DO isend=1,req%nsend 1471 send=>req%send(isend) 1472 value=>send%value 1473 1474 IF (send%rank/=mpi_rank) THEN 1475 1476 ireq=send%ireq 1477 buffer_r=>message%buffers(ireq)%r 1478 msize=send%size 1479 moffset=send%offset 1480 1481 call enter_profile(profile_mpi_copies) 1482 CALL trace_start("copy_to_buffer") 1483 !$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice) 1484 DO d4=1,dim4 1485 DO d3=lbegin,lend 1486 offset=moffset*dim3*dim4 + dim3*msize*(d4-1) + & 1487 (d3-1)*msize 1488 !$acc loop 1489 DO n=1,msize 1490 buffer_r(n+offset)=rval4d(value(n),d3,d4) 1491 ENDDO 1492 ENDDO 1493 ENDDO 1494 CALL trace_end("copy_to_buffer") 1495 call exit_profile(profile_mpi_copies) 1496 1497 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1498 CALL enter_profile(profile_mpi_omp_barrier) 1499 !$OMP BARRIER 1500 CALL exit_profile(profile_mpi_omp_barrier) 1501 1502 ENDIF 1503 1504 IF (is_omp_level_master) THEN 1505 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1506 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1507 !$OMP CRITICAL 1508 CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank, & 1509 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1510 !$OMP END CRITICAL 1511 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1512 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1513 CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank, & 1514 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1515 ENDIF 1516 ENDIF 1517 ELSE 1518 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1519 CALL enter_profile(profile_mpi_omp_barrier) 1520 !$OMP BARRIER 1521 CALL exit_profile(profile_mpi_omp_barrier) 1522 1523 ENDIF 1524 ENDIF 1525 ENDDO 1526 1527 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1528 DO isend=req%nsend+1,max_req 1529 CALL enter_profile(profile_mpi_omp_barrier) 1530 !$OMP BARRIER 1531 CALL exit_profile(profile_mpi_omp_barrier) 1532 1533 ENDDO 1534 ENDIF 1535 1536 ENDDO 1537 1538 DO ind=1,ndomain 1539 IF (.NOT. assigned_domain(ind) ) CYCLE 1540 1541 dim3=size(field(ind)%rval4d,2) 1542 CALL distrib_level(1,dim3, lbegin,lend) 1543 dim4=size(field(ind)%rval4d,3) 1544 rval4d=>field(ind)%rval4d 1545 req=>message%request(ind) 1546 1547 DO irecv=1,req%nrecv 1548 recv=>req%recv(irecv) 1549 IF (recv%rank==mpi_rank) THEN 1550 value=>recv%value 1551 src_value => recv%src_value 1552 src_rval4d=>field(recv%domain)%rval4d 1553 sgn=>recv%sign 1554 msize=recv%size 1555 call enter_profile(profile_mpi_copies) 1556 CALL trace_start("copy_data") 1557 !$acc parallel loop collapse(3) default(present) async if (field(ind)%ondevice) 1558 DO d4=1,dim4 1559 DO d3=lbegin,lend 1560 DO n=1,msize 1561 rval4d(value(n),d3,d4)=src_rval4d(src_value(n),d3,d4)*sgn(n) 1562 ENDDO 1563 ENDDO 1564 ENDDO 1565 call exit_profile(profile_mpi_copies) 1566 CALL trace_end("copy_data") 1567 1568 ELSE 1569 1570 ireq=recv%ireq 1571 buffer_r=>message%buffers(ireq)%r 1572 IF (is_omp_level_master) THEN 1573 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1574 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1575 !$OMP CRITICAL 1576 CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank, & 1577 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1578 !$OMP END CRITICAL 1579 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1580 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1581 CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank, & 1582 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1583 ENDIF 1584 ENDIF 1585 ENDIF 1586 ENDDO 1587 ENDDO 1588 1589 ENDIF 1590 1591 IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 1592 CALL enter_profile(profile_mpi_omp_barrier) 1593 !$acc wait 1594 !$OMP BARRIER 1595 CALL exit_profile(profile_mpi_omp_barrier) 1596 !$OMP MASTER 1597 1598 DO ireq=1,message%nreq_send 1599 buffer_r=>message%buffers(ireq)%r 1600 msize=message%buffers(ireq)%size 1601 rank=message%buffers(ireq)%rank 1602 ! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation 1603 IF (message%ondevice) THEN 1604 !$acc host_data use_device(buffer_r) ! if (message%ondevice) 1605 CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number, & 1606 comm_icosa, message%mpi_req(ireq),ierr) 1607 !$acc end host_data 1608 ELSE 1609 CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number, & 1610 comm_icosa, message%mpi_req(ireq),ierr) 1611 ENDIF 1612 ENDDO 1613 1614 DO ireq=message%nreq_send+1,message%nreq_send+message%nreq_recv 1615 buffer_r=>message%buffers(ireq)%r 1616 msize=message%buffers(ireq)%size 1617 rank=message%buffers(ireq)%rank 1618 ! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation 1619 IF (message%ondevice) THEN 1620 !$acc host_data use_device(buffer_r) ! if (message%ondevice) 1621 CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number, & 1622 comm_icosa, message%mpi_req(ireq),ierr) 1623 !$acc end host_data 1624 ELSE 1625 CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number, & 1626 comm_icosa, message%mpi_req(ireq),ierr) 1627 ENDIF 1628 ENDDO 1629 1630 !$OMP END MASTER 1631 ENDIF 1632 ENDIF 1633 CALL enter_profile(profile_mpi_omp_barrier) 1634 !$OMP BARRIER 1635 CALL exit_profile(profile_mpi_omp_barrier) 1636 1637 ! CALL trace_end("send_message_mpi") 1638 1639 CALL exit_profile(id_mpi) 1640 1641 END SUBROUTINE send_message_mpi 1642 1643 SUBROUTINE test_message_mpi(message) 1644 IMPLICIT NONE 1645 TYPE(t_message) :: message 1646 1647 INTEGER :: ierr 1648 1649 !$OMP MASTER 1650 IF (message%pending .AND. .NOT. message%completed) CALL MPI_TESTALL(message%nreq,& 1651 message%mpi_req,message%completed,message%status,ierr) 1652 !$OMP END MASTER 1653 END SUBROUTINE test_message_mpi 1654 1655 1656 SUBROUTINE wait_message_mpi(message) 1657 USE profiling_mod 1658 USE field_mod 1659 USE domain_mod 1660 USE mpi_mod 1661 USE mpipara 1662 USE omp_para 1663 USE trace 1664 IMPLICIT NONE 1665 TYPE(t_message) :: message 1666 1667 TYPE(t_field),POINTER :: field(:) 1668 REAL(rstd),POINTER :: rval2d(:) 1669 REAL(rstd),POINTER :: rval3d(:,:) 1670 REAL(rstd),POINTER :: rval4d(:,:,:) 1671 REAL(rstd),POINTER :: buffer_r(:) 1672 INTEGER,POINTER :: value(:) 1673 INTEGER,POINTER :: sgn(:) 1674 TYPE(ARRAY),POINTER :: recv 1675 TYPE(t_request),POINTER :: req 1676 INTEGER :: irecv 1677 INTEGER :: ireq,nreq 1678 INTEGER :: ind,n 1679 INTEGER :: dim3,dim4,d3,d4,lbegin,lend 1680 INTEGER :: offset, msize, moffset 1681 1682 message%open=.FALSE. 1683 IF (.NOT. message%pending) RETURN 1684 1685 CALL enter_profile(id_mpi) 1686 1687 ! CALL trace_start("wait_message_mpi") 1688 1689 field=>message%field 1690 nreq=message%nreq 1691 1692 IF (field(1)%data_type==type_real) THEN 1693 IF (field(1)%ndim==2) THEN 1694 1695 call enter_profile(profile_mpi_waitall) 1696 !$OMP MASTER 1697 IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, & 1698 message%status,ierr) 1699 !$OMP END MASTER 1700 !$OMP BARRIER 1701 call exit_profile(profile_mpi_waitall) 1702 call enter_profile(profile_mpi_copies) 1703 DO ind=1,ndomain 1704 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1705 1706 rval2d=>field(ind)%rval2d 1707 req=>message%request(ind) 1708 DO irecv=1,req%nrecv 1709 recv=>req%recv(irecv) 1710 IF (recv%rank/=mpi_rank) THEN 1711 ireq=recv%ireq 1712 buffer_r=>message%buffers(ireq)%r 1713 value=>recv%value 1714 sgn=>recv%sign 1715 offset=recv%offset 1716 msize=recv%size 1717 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1718 DO n=1,msize 1719 rval2d(value(n))=buffer_r(n+offset)*sgn(n) 1720 ENDDO 1721 1722 ENDIF 1723 ENDDO 1724 1725 ENDDO 1726 call exit_profile(profile_mpi_copies) 1727 1728 1729 ELSE IF (field(1)%ndim==3) THEN 1730 call enter_profile(profile_mpi_waitall) 1731 !$OMP MASTER 1732 IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, & 1733 message%status,ierr) 1734 !$OMP END MASTER 1735 !$OMP BARRIER 1736 call exit_profile(profile_mpi_waitall) 1737 1738 1739 DO ind=1,ndomain 1740 IF (.NOT. assigned_domain(ind) ) CYCLE 1741 1742 rval3d=>field(ind)%rval3d 1743 req=>message%request(ind) 1744 DO irecv=1,req%nrecv 1745 recv=>req%recv(irecv) 1746 IF (recv%rank/=mpi_rank) THEN 1747 ireq=recv%ireq 1748 buffer_r=>message%buffers(ireq)%r 1749 value=>recv%value 1750 sgn=>recv%sign 1751 1752 dim3=size(rval3d,2) 1753 1754 CALL distrib_level(1,dim3, lbegin,lend) 1755 msize=recv%size 1756 moffset=recv%offset 1757 call enter_profile(profile_mpi_copies) 1758 CALL trace_start("copy_from_buffer") 1759 1760 IF (req%vector) THEN 1761 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1762 DO d3=lbegin,lend 1763 offset=moffset*dim3 + (d3-1)*msize 1764 !$acc loop 1765 DO n=1,msize 1766 rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n) 1767 ENDDO 1768 ENDDO 1769 ELSE 1770 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1771 DO d3=lbegin,lend 1772 offset=moffset*dim3 + (d3-1)*msize 1773 !$acc loop 1774 DO n=1,msize 1775 rval3d(value(n),d3)=buffer_r(n+offset) 1776 ENDDO 1777 ENDDO 1778 ENDIF 1779 1780 CALL trace_end("copy_from_buffer") 1781 call exit_profile(profile_mpi_copies) 1782 ENDIF 1783 ENDDO 1784 1785 ENDDO 1786 1787 ELSE IF (field(1)%ndim==4) THEN 1788 call enter_profile(profile_mpi_waitall) 1789 !$OMP MASTER 1790 IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, & 1791 message%status,ierr) 1792 !$OMP END MASTER 1793 !$OMP BARRIER 1794 call exit_profile(profile_mpi_waitall) 1795 1796 1797 DO ind=1,ndomain 1798 IF (.NOT. assigned_domain(ind) ) CYCLE 1799 1800 rval4d=>field(ind)%rval4d 1801 req=>message%request(ind) 1802 DO irecv=1,req%nrecv 1803 recv=>req%recv(irecv) 1804 IF (recv%rank/=mpi_rank) THEN 1805 ireq=recv%ireq 1806 buffer_r=>message%buffers(ireq)%r 1807 value=>recv%value 1808 sgn=>recv%sign 1809 1810 dim3=size(rval4d,2) 1811 CALL distrib_level(1,dim3, lbegin,lend) 1812 dim4=size(rval4d,3) 1813 msize=recv%size 1814 moffset=recv%offset 1815 call enter_profile(profile_mpi_copies) 1816 CALL trace_start("copy_from_buffer") 1817 !$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice) 1818 DO d4=1,dim4 1819 DO d3=lbegin,lend 1820 offset=moffset*dim3*dim4 + dim3*msize*(d4-1) + & 1821 (d3-1)*msize 1822 !$acc loop 1823 DO n=1,msize 1824 rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n) 1825 ENDDO 1826 ENDDO 1827 ENDDO 1828 CALL trace_end("copy_from_buffer") 1829 call exit_profile(profile_mpi_copies) 1830 ENDIF 1831 ENDDO 1832 1833 ENDDO 1834 1835 ENDIF 1836 1837 ENDIF 1838 1839 !$OMP MASTER 1840 message%pending=.FALSE. 1841 !$OMP END MASTER 1842 1843 ! CALL trace_end("wait_message_mpi") 1844 !$OMP BARRIER 1845 1846 CALL exit_profile(id_mpi) 1847 1848 END SUBROUTINE wait_message_mpi 1849 1850 SUBROUTINE transfert_request_mpi(field,request) 1851 USE field_mod 1852 IMPLICIT NONE 1853 TYPE(t_field),POINTER :: field(:) 1854 TYPE(t_request),POINTER :: request(:) 1855 1856 TYPE(t_message),SAVE :: message 1857 1858 1859 CALL init_message_mpi(field,request, message) 1860 CALL transfert_message_mpi(field,message) 1861 CALL finalize_message_mpi(field,message) 1862 1863 END SUBROUTINE transfert_request_mpi 1864 1865 1866 1867 SUBROUTINE transfert_request_seq(field,request) 1868 USE field_mod 1869 USE domain_mod 1870 IMPLICIT NONE 1871 TYPE(t_field),POINTER :: field(:) 1872 TYPE(t_request),POINTER :: request(:) 1873 REAL(rstd),POINTER :: rval2d(:) 1874 REAL(rstd),POINTER :: rval3d(:,:) 1875 REAL(rstd),POINTER :: rval4d(:,:,:) 1876 INTEGER :: ind 1877 TYPE(t_request),POINTER :: req 1878 INTEGER :: n 1879 1880 DO ind=1,ndomain 1881 req=>request(ind) 1882 rval2d=>field(ind)%rval2d 1883 rval3d=>field(ind)%rval3d 1884 rval4d=>field(ind)%rval4d 1885 1886 IF (field(ind)%data_type==type_real) THEN 1887 IF (field(ind)%ndim==2) THEN 1888 DO n=1,req%size 1889 rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*& 1890 req%target_sign(n) 1891 ENDDO 1892 ELSE IF (field(ind)%ndim==3) THEN 1893 DO n=1,req%size 1894 rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*& 1895 req%target_sign(n) 1896 ENDDO 1897 ELSE IF (field(ind)%ndim==4) THEN 1898 DO n=1,req%size 1899 rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*& 1900 req%target_sign(n) 1901 ENDDO 1902 ENDIF 1903 ENDIF 1904 1905 ENDDO 1906 1907 END SUBROUTINE transfert_request_seq 1908 1909 1910 SUBROUTINE gather_field(field_loc,field_glo) 1911 USE field_mod 1912 USE domain_mod 1913 USE mpi_mod 1914 USE mpipara 1915 IMPLICIT NONE 1916 TYPE(t_field),POINTER :: field_loc(:) 1917 TYPE(t_field),POINTER :: field_glo(:) 1918 INTEGER, ALLOCATABLE :: mpi_req(:) 1919 INTEGER, ALLOCATABLE :: status(:,:) 1920 INTEGER :: ireq,nreq 1921 INTEGER :: ind_glo,ind_loc 1922 1923 IF (.NOT. using_mpi) THEN 1924 1925 DO ind_loc=1,ndomain 1926 IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d 1927 IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d 1928 IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d 1929 ENDDO 1930 1931 ELSE 1932 1933 nreq=ndomain 1934 IF (mpi_rank==0) nreq=nreq+ndomain_glo 1935 ALLOCATE(mpi_req(nreq)) 1936 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 1937 1938 1939 ireq=0 1940 IF (mpi_rank==0) THEN 1941 DO ind_glo=1,ndomain_glo 1942 ireq=ireq+1 1943 1944 IF (field_glo(ind_glo)%ndim==2) THEN 1945 CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , & 1946 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1947 1948 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 1949 CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , & 1950 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1951 1952 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 1953 CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , & 1954 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1955 ENDIF 1956 1957 ENDDO 1958 ENDIF 1959 1960 DO ind_loc=1,ndomain 1961 ireq=ireq+1 1962 1963 IF (field_loc(ind_loc)%ndim==2) THEN 1964 CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , & 1965 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1966 ELSE IF (field_loc(ind_loc)%ndim==3) THEN 1967 CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , & 1968 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1969 ELSE IF (field_loc(ind_loc)%ndim==4) THEN 1970 CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , & 1971 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1972 ENDIF 1973 1974 ENDDO 1975 1976 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 1977 1978 ENDIF 1979 1980 END SUBROUTINE gather_field 1981 1982 SUBROUTINE bcast_field(field_glo) 1983 USE field_mod 1984 USE domain_mod 1985 USE mpi_mod 1986 USE mpipara 1987 IMPLICIT NONE 1988 TYPE(t_field),POINTER :: field_glo(:) 1989 INTEGER :: ind_glo 1990 1991 IF (.NOT. using_mpi) THEN 1992 1993 ! nothing to do 1994 1995 ELSE 1996 1997 DO ind_glo=1,ndomain_glo 1998 1999 IF (field_glo(ind_glo)%ndim==2) THEN 2000 CALL MPI_BCAST(field_glo(ind_glo)%rval2d, size(field_glo(ind_glo)%rval2d) , MPI_REAL8, 0, comm_icosa, ierr) 2001 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 2002 CALL MPI_BCAST(field_glo(ind_glo)%rval3d, size(field_glo(ind_glo)%rval3d) , MPI_REAL8, 0, comm_icosa, ierr) 2003 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 2004 CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr) 2005 ENDIF 2006 2007 ENDDO 2008 ENDIF 2009 2010 END SUBROUTINE bcast_field 2011 2012 SUBROUTINE scatter_field(field_glo,field_loc) 2013 USE field_mod 2014 USE domain_mod 2015 USE mpi_mod 2016 USE mpipara 2017 IMPLICIT NONE 2018 TYPE(t_field),POINTER :: field_glo(:) 2019 TYPE(t_field),POINTER :: field_loc(:) 2020 INTEGER, ALLOCATABLE :: mpi_req(:) 2021 INTEGER, ALLOCATABLE :: status(:,:) 2022 INTEGER :: ireq,nreq 2023 INTEGER :: ind_glo,ind_loc 2024 2025 IF (.NOT. using_mpi) THEN 2026 2027 DO ind_loc=1,ndomain 2028 IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d 2029 IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d 2030 IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 2031 ENDDO 2032 2033 ELSE 2034 2035 nreq=ndomain 2036 IF (mpi_rank==0) nreq=nreq+ndomain_glo 2037 ALLOCATE(mpi_req(nreq)) 2038 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 2039 2040 2041 ireq=0 2042 IF (mpi_rank==0) THEN 2043 DO ind_glo=1,ndomain_glo 2044 ireq=ireq+1 2045 2046 IF (field_glo(ind_glo)%ndim==2) THEN 2047 CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , & 2048 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 2049 2050 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 2051 CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , & 2052 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 2053 2054 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 2055 CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , & 2056 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 2057 ENDIF 2058 2059 ENDDO 2060 ENDIF 2061 2062 DO ind_loc=1,ndomain 2063 ireq=ireq+1 2064 2065 IF (field_loc(ind_loc)%ndim==2) THEN 2066 CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , & 2067 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 2068 ELSE IF (field_loc(ind_loc)%ndim==3) THEN 2069 CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , & 2070 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 2071 ELSE IF (field_loc(ind_loc)%ndim==4) THEN 2072 CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , & 2073 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 2074 ENDIF 2075 2076 ENDDO 2077 2078 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 2079 2080 ENDIF 2081 2082 END SUBROUTINE scatter_field 2083 2084 SUBROUTINE trace_in 2085 USE trace 2086 IMPLICIT NONE 2087 2088 CALL trace_start("transfert_buffer") 2089 END SUBROUTINE trace_in 2090 2091 SUBROUTINE trace_out 2092 USE trace 2093 IMPLICIT NONE 2094 2095 CALL trace_end("transfert_buffer") 2096 END SUBROUTINE trace_out 2097 2098 2099 2100 2101 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2102 !! Definition des Broadcast --> 4D !! 2103 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2104 2105 !! -- Les chaine de charactᅵre -- !! 2106 2107 SUBROUTINE bcast_mpi_c(var1) 2108 IMPLICIT NONE 2109 CHARACTER(LEN=*),INTENT(INOUT) :: Var1 2110 2111 CALL bcast_mpi_cgen(Var1,len(Var1)) 2112 2113 END SUBROUTINE bcast_mpi_c 2114 2115 !! -- Les entiers -- !! 2116 2117 SUBROUTINE bcast_mpi_i(var) 2118 USE mpipara 2119 IMPLICIT NONE 2120 INTEGER,INTENT(INOUT) :: Var 2121 2122 INTEGER :: var_tmp(1) 2123 2124 IF (is_mpi_master) var_tmp(1)=var 2125 CALL bcast_mpi_igen(Var_tmp,1) 2126 var=var_tmp(1) 2127 2128 END SUBROUTINE bcast_mpi_i 2129 2130 SUBROUTINE bcast_mpi_i1(var) 2131 IMPLICIT NONE 2132 INTEGER,INTENT(INOUT) :: Var(:) 2133 2134 CALL bcast_mpi_igen(Var,size(Var)) 2135 2136 END SUBROUTINE bcast_mpi_i1 2137 2138 SUBROUTINE bcast_mpi_i2(var) 2139 IMPLICIT NONE 2140 INTEGER,INTENT(INOUT) :: Var(:,:) 2141 2142 CALL bcast_mpi_igen(Var,size(Var)) 2143 2144 END SUBROUTINE bcast_mpi_i2 2145 2146 SUBROUTINE bcast_mpi_i3(var) 2147 IMPLICIT NONE 2148 INTEGER,INTENT(INOUT) :: Var(:,:,:) 2149 2150 CALL bcast_mpi_igen(Var,size(Var)) 2151 2152 END SUBROUTINE bcast_mpi_i3 2153 2154 SUBROUTINE bcast_mpi_i4(var) 2155 IMPLICIT NONE 2156 INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 2157 2158 CALL bcast_mpi_igen(Var,size(Var)) 2159 2160 END SUBROUTINE bcast_mpi_i4 2161 2162 2163 !! -- Les reels -- !! 2164 2165 SUBROUTINE bcast_mpi_r(var) 2166 USE mpipara 2167 IMPLICIT NONE 2168 REAL,INTENT(INOUT) :: Var 2169 REAL :: var_tmp(1) 2170 2171 IF (is_mpi_master) var_tmp(1)=var 2172 CALL bcast_mpi_rgen(Var_tmp,1) 2173 var=var_tmp(1) 2174 2175 END SUBROUTINE bcast_mpi_r 2176 2177 SUBROUTINE bcast_mpi_r1(var) 2178 IMPLICIT NONE 2179 REAL,INTENT(INOUT) :: Var(:) 2180 2181 CALL bcast_mpi_rgen(Var,size(Var)) 2182 2183 END SUBROUTINE bcast_mpi_r1 2184 2185 SUBROUTINE bcast_mpi_r2(var) 2186 IMPLICIT NONE 2187 REAL,INTENT(INOUT) :: Var(:,:) 2188 2189 CALL bcast_mpi_rgen(Var,size(Var)) 2190 2191 END SUBROUTINE bcast_mpi_r2 2192 2193 SUBROUTINE bcast_mpi_r3(var) 2194 IMPLICIT NONE 2195 REAL,INTENT(INOUT) :: Var(:,:,:) 2196 2197 CALL bcast_mpi_rgen(Var,size(Var)) 2198 2199 END SUBROUTINE bcast_mpi_r3 2200 2201 SUBROUTINE bcast_mpi_r4(var) 2202 IMPLICIT NONE 2203 REAL,INTENT(INOUT) :: Var(:,:,:,:) 2204 2205 CALL bcast_mpi_rgen(Var,size(Var)) 2206 2207 END SUBROUTINE bcast_mpi_r4 2208 2209 !! -- Les booleans -- !! 2210 2211 SUBROUTINE bcast_mpi_l(var) 2212 USE mpipara 2213 IMPLICIT NONE 2214 LOGICAL,INTENT(INOUT) :: Var 2215 LOGICAL :: var_tmp(1) 2216 2217 IF (is_mpi_master) var_tmp(1)=var 2218 CALL bcast_mpi_lgen(Var_tmp,1) 2219 var=var_tmp(1) 2220 2221 END SUBROUTINE bcast_mpi_l 2222 2223 SUBROUTINE bcast_mpi_l1(var) 2224 IMPLICIT NONE 2225 LOGICAL,INTENT(INOUT) :: Var(:) 2226 2227 CALL bcast_mpi_lgen(Var,size(Var)) 2228 2229 END SUBROUTINE bcast_mpi_l1 2230 2231 SUBROUTINE bcast_mpi_l2(var) 2232 IMPLICIT NONE 2233 LOGICAL,INTENT(INOUT) :: Var(:,:) 2234 2235 CALL bcast_mpi_lgen(Var,size(Var)) 2236 2237 END SUBROUTINE bcast_mpi_l2 2238 2239 SUBROUTINE bcast_mpi_l3(var) 2240 IMPLICIT NONE 2241 LOGICAL,INTENT(INOUT) :: Var(:,:,:) 2242 2243 CALL bcast_mpi_lgen(Var,size(Var)) 2244 2245 END SUBROUTINE bcast_mpi_l3 2246 2247 SUBROUTINE bcast_mpi_l4(var) 2248 IMPLICIT NONE 2249 LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 2250 2251 CALL bcast_mpi_lgen(Var,size(Var)) 2252 2253 END SUBROUTINE bcast_mpi_l4 2254 2255 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2256 !! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! 2257 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2258 2259 SUBROUTINE bcast_mpi_cgen(var,nb) 2260 USE mpi_mod 2261 USE mpipara 2262 IMPLICIT NONE 2263 2264 CHARACTER(LEN=*),INTENT(INOUT) :: Var 2265 INTEGER,INTENT(IN) :: nb 2266 2267 IF (.NOT. using_mpi) RETURN 2268 2269 CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr) 2270 2271 END SUBROUTINE bcast_mpi_cgen 2272 2273 2274 2275 SUBROUTINE bcast_mpi_igen(var,nb) 2276 USE mpi_mod 2277 USE mpipara 2278 IMPLICIT NONE 2279 INTEGER,INTENT(IN) :: nb 2280 INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var 2281 2282 IF (.NOT. using_mpi) RETURN 2283 2284 CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr) 2285 2286 END SUBROUTINE bcast_mpi_igen 2287 2288 2289 2290 2291 SUBROUTINE bcast_mpi_rgen(var,nb) 2292 USE mpi_mod 2293 USE mpipara 2294 IMPLICIT NONE 2295 INTEGER,INTENT(IN) :: nb 2296 REAL,DIMENSION(nb),INTENT(INOUT) :: Var 2297 2298 IF (.NOT. using_mpi) RETURN 2299 2300 CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr) 2301 2302 END SUBROUTINE bcast_mpi_rgen 2303 2304 2305 2306 2307 SUBROUTINE bcast_mpi_lgen(var,nb) 2308 USE mpi_mod 2309 USE mpipara 2310 IMPLICIT NONE 2311 INTEGER,INTENT(IN) :: nb 2312 LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var 2313 2314 IF (.NOT. using_mpi) RETURN 2315 2316 CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr) 2317 2318 END SUBROUTINE bcast_mpi_lgen 2319 2320 2321 END MODULE transfert_mpi_mod 2322 2323 2324 2325 2326 472 call enter_profile(profile_mpi) 473 474 CALL distrib_level( 1, size(message%field(1)%rval4d, 2), d3_begin, d3_end ) 475 476 call enter_profile(profile_mpi_waitall) 477 !$omp master 478 call MPI_Waitall( size(message%mpi_requests_out), message%mpi_requests_out, MPI_STATUSES_IGNORE, ierr ) 479 call MPI_Waitall( size(message%mpi_requests_in), message%mpi_requests_in, MPI_STATUSES_IGNORE, ierr ) 480 !$omp end master 481 call exit_profile(profile_mpi_waitall) 482 483 call enter_profile(profile_mpi_barrier) 484 !$omp barrier 485 call exit_profile(profile_mpi_barrier) 486 487 call enter_profile(profile_mpi_copies) 488 !$acc data present(message) async if(message%ondevice) 489 490 dim4 = size(message%field(1)%rval4d, 3) 491 ! Buffer to Halo : copy inbound message to field 492 !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) 493 do i = 1, size( message%message_in ) 494 if( assigned_domain( message%message_in(i)%ind_loc ) ) then 495 !$acc loop collapse(2) 496 do d4 = 1, dim4 497 do d3 = d3_begin, d3_end 498 !$acc loop 499 do k = 1, size(message%message_in(i)%displs) 500 message%field(message%message_in(i)%ind_loc)%rval4d(message%message_in(i)%displs(k),d3,d4) = message%message_in(i)%sign(k)*message%message_in(i)%buff(k,d3,d4) 501 end do 502 end do 503 end do 504 endif 505 end do 506 507 !$acc end data 508 call exit_profile(profile_mpi_copies) 509 510 !$omp master 511 message%wait_seq = message%wait_seq + 1 512 !$omp end master 513 514 call enter_profile(profile_mpi_barrier) 515 !$omp barrier 516 call exit_profile(profile_mpi_barrier) 517 call exit_profile(profile_mpi) 518 end subroutine 519 end module -
codes/icosagcm/trunk/src/parallel/transfert_mpi_legacy.f90
r962 r963 1 MODULE transfert_mpi_ mod1 MODULE transfert_mpi_legacy_mod 2 2 USE genmod 3 3 USE field_mod 4 4 IMPLICIT NONE 5 5 6 6 TYPE array 7 7 INTEGER,POINTER :: value(:)=>null() … … 17 17 INTEGER,POINTER :: src_value(:)=>null() 18 18 END TYPE array 19 19 20 20 TYPE t_buffer 21 21 REAL,POINTER :: r(:) 22 22 INTEGER :: size 23 23 INTEGER :: rank 24 END TYPE t_buffer 25 24 END TYPE t_buffer 25 26 26 TYPE t_request 27 27 INTEGER :: type_field … … 45 45 TYPE(ARRAY),POINTER :: send(:) 46 46 END TYPE t_request 47 47 48 48 TYPE(t_request),SAVE,POINTER :: req_i1(:) 49 49 TYPE(t_request),SAVE,POINTER :: req_e1_scal(:) 50 50 TYPE(t_request),SAVE,POINTER :: req_e1_vect(:) 51 51 TYPE(t_request),SAVE,POINTER :: req_z1_scal(:) 52 52 53 53 TYPE(t_request),SAVE,POINTER :: req_i0(:) 54 54 TYPE(t_request),SAVE,POINTER :: req_e0_scal(:) … … 60 60 INTEGER :: tag 61 61 INTEGER :: isend 62 END TYPE t_reorder 63 62 END TYPE t_reorder 63 64 64 TYPE t_message 65 65 CHARACTER(LEN=100) :: name ! for debug … … 71 71 INTEGER, POINTER :: mpi_req(:) 72 72 INTEGER, POINTER :: status(:,:) 73 TYPE(t_buffer),POINTER :: buffers(:) 73 TYPE(t_buffer),POINTER :: buffers(:) 74 74 TYPE(t_field),POINTER :: field(:) 75 75 LOGICAL :: completed … … 80 80 END TYPE t_message 81 81 82 83 INTERFACE bcast_mpi84 MODULE PROCEDURE bcast_mpi_c, &85 bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &86 bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &87 bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l488 END INTERFACE89 90 82 integer :: profile_mpi_copies, profile_mpi_waitall, profile_mpi_omp_barrier 91 83 92 84 CONTAINS 93 94 85 86 95 87 SUBROUTINE init_transfert 96 88 USE profiling_mod … … 119 111 DO j=jj_begin,jj_end 120 112 CALL request_add_point(ind,ii_end+1,j,req_i1) 121 ENDDO 113 ENDDO 122 114 DO i=ii_begin,ii_end 123 115 CALL request_add_point(ind,i,jj_end+1,req_i1) 124 ENDDO 116 ENDDO 125 117 126 118 DO j=jj_begin,jj_end+1 127 119 CALL request_add_point(ind,ii_begin-1,j,req_i1) 128 ENDDO 129 120 ENDDO 121 130 122 ENDDO 131 123 132 124 CALL finalize_request(req_i1) 133 125 … … 137 129 DO ind=1,ndomain 138 130 CALL swap_dimensions(ind) 139 131 140 132 DO i=ii_begin,ii_end 141 133 CALL request_add_point(ind,i,jj_begin,req_i0) … … 144 136 DO j=jj_begin,jj_end 145 137 CALL request_add_point(ind,ii_end,j,req_i0) 146 ENDDO 147 138 ENDDO 139 148 140 DO i=ii_begin,ii_end 149 141 CALL request_add_point(ind,i,jj_end,req_i0) 150 ENDDO 142 ENDDO 151 143 152 144 DO j=jj_begin,jj_end 153 145 CALL request_add_point(ind,ii_begin,j,req_i0) 154 ENDDO 155 146 ENDDO 147 156 148 ENDDO 157 158 CALL finalize_request(req_i0) 149 150 CALL finalize_request(req_i0) 159 151 160 152 … … 169 161 DO j=jj_begin,jj_end 170 162 CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left) 171 ENDDO 163 ENDDO 172 164 DO j=jj_begin,jj_end 173 165 CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup) 174 ENDDO 175 166 ENDDO 167 176 168 DO i=ii_begin,ii_end 177 169 CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown) 178 170 CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown) 179 ENDDO 171 ENDDO 180 172 181 173 DO j=jj_begin,jj_end 182 174 CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right) 183 ENDDO 175 ENDDO 184 176 DO j=jj_begin,jj_end 185 177 CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown) 186 ENDDO 178 ENDDO 187 179 188 180 ENDDO … … 200 192 CALL request_add_point(ind,i,jj_end,req_e0_scal,right) 201 193 ENDDO 202 194 203 195 DO j=jj_begin+1,jj_end-1 204 196 CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup) 205 197 CALL request_add_point(ind,ii_end,j,req_e0_scal,rup) 206 ENDDO 198 ENDDO 207 199 208 200 CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left) … … 216 208 217 209 218 210 219 211 CALL create_request(field_u,req_e1_vect,.TRUE.) 220 212 DO ind=1,ndomain … … 227 219 DO j=jj_begin,jj_end 228 220 CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left) 229 ENDDO 221 ENDDO 230 222 DO j=jj_begin,jj_end 231 223 CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup) 232 ENDDO 233 224 ENDDO 225 234 226 DO i=ii_begin,ii_end 235 227 CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown) 236 228 CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown) 237 ENDDO 229 ENDDO 238 230 239 231 DO j=jj_begin,jj_end 240 232 CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right) 241 ENDDO 233 ENDDO 242 234 DO j=jj_begin,jj_end 243 235 CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown) 244 ENDDO 245 246 247 ENDDO 236 ENDDO 237 238 239 ENDDO 248 240 249 241 CALL finalize_request(req_e1_vect) 250 251 242 243 252 244 CALL create_request(field_u,req_e0_vect,.TRUE.) 253 245 DO ind=1,ndomain 254 246 CALL swap_dimensions(ind) 255 247 256 248 DO i=ii_begin+1,ii_end-1 257 249 CALL request_add_point(ind,i,jj_begin,req_e0_vect,right) 258 250 CALL request_add_point(ind,i,jj_end,req_e0_vect,right) 259 251 ENDDO 260 252 261 253 DO j=jj_begin+1,jj_end-1 262 254 CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup) 263 255 CALL request_add_point(ind,ii_end,j,req_e0_vect,rup) 264 ENDDO 256 ENDDO 265 257 266 258 CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left) … … 268 260 CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left) 269 261 CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown) 270 271 ENDDO 262 263 ENDDO 272 264 273 265 CALL finalize_request(req_e0_vect) … … 283 275 DO j=jj_begin,jj_end 284 276 CALL request_add_point(ind,ii_end+1,j,req_z1_scal,vlup) 285 ENDDO 277 ENDDO 286 278 DO j=jj_begin,jj_end 287 279 CALL request_add_point(ind,ii_end+1,j-1,req_z1_scal,vup) 288 ENDDO 289 280 ENDDO 281 290 282 DO i=ii_begin,ii_end 291 283 CALL request_add_point(ind,i,jj_end+1,req_z1_scal,vdown) 292 284 CALL request_add_point(ind,i-1,jj_end+1,req_z1_scal,vrdown) 293 ENDDO 285 ENDDO 294 286 295 287 DO j=jj_begin,jj_end 296 288 CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrup) 297 ENDDO 289 ENDDO 298 290 DO j=jj_begin,jj_end 299 291 CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrdown) 300 ENDDO 292 ENDDO 301 293 302 294 ENDDO … … 305 297 306 298 END SUBROUTINE init_transfert 307 299 308 300 SUBROUTINE create_request(type_field,request,vector) 309 301 USE domain_mod … … 313 305 TYPE(t_request),POINTER :: request(:) 314 306 LOGICAL,OPTIONAL :: vector 315 307 316 308 TYPE(t_request),POINTER :: req 317 309 TYPE(t_domain),POINTER :: d 318 310 INTEGER :: ind 319 311 INTEGER :: max_size 320 312 321 313 ALLOCATE(request(ndomain)) 322 314 … … 346 338 ALLOCATE(req%target_sign(req%max_size)) 347 339 ENDDO 348 340 349 341 END SUBROUTINE create_request 350 342 … … 352 344 IMPLICIT NONE 353 345 TYPE(t_request),POINTER :: req 354 346 355 347 INTEGER,POINTER :: src_domain(:) 356 348 INTEGER,POINTER :: src_ind(:) … … 380 372 ALLOCATE(req%target_j(req%max_size*2)) 381 373 ALLOCATE(req%target_sign(req%max_size*2)) 382 374 383 375 req%src_domain(1:req%max_size)=src_domain(:) 384 376 req%src_ind(1:req%max_size)=src_ind(:) … … 389 381 req%target_j(1:req%max_size)=target_j(:) 390 382 req%target_sign(1:req%max_size)=target_sign(:) 391 383 392 384 req%max_size=req%max_size*2 393 385 394 386 DEALLOCATE(src_domain) 395 387 DEALLOCATE(src_ind) … … 403 395 END SUBROUTINE reallocate_request 404 396 405 397 406 398 SUBROUTINE request_add_point(ind,i,j,request,pos) 407 399 USE domain_mod … … 413 405 TYPE(t_request),POINTER :: request(:) 414 406 INTEGER,INTENT(IN),OPTIONAL :: pos 415 407 416 408 INTEGER :: src_domain 417 409 INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta 418 410 TYPE(t_request),POINTER :: req 419 411 TYPE(t_domain),POINTER :: d 420 412 421 413 req=>request(ind) 422 414 d=>domain(ind) 423 415 424 416 IF (req%max_size==req%size) CALL reallocate_request(req) 425 417 req%size=req%size+1 … … 444 436 src_delta=domain(ind)%delta(i,j) 445 437 src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1 446 438 447 439 req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos) 448 440 … … 464 456 src_pos=domain(ind)%vertex_assign_pos(pos-1,i,j)+1 465 457 466 458 467 459 req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos) 468 460 req%target_sign(req%size)=1 … … 471 463 ENDIF 472 464 END SUBROUTINE request_add_point 473 474 465 466 475 467 SUBROUTINE Finalize_request(request) 476 468 USE mpipara … … 497 489 LOGICAL,PARAMETER :: debug = .FALSE. 498 490 499 491 500 492 IF (.NOT. using_mpi) RETURN 501 493 502 494 DO ind_loc=1,ndomain 503 495 req=>request(ind_loc) 504 496 505 497 nb_data_domain_recv(:) = 0 506 498 nb_domain_recv(:) = 0 507 499 tag_rank(:)=0 508 500 509 501 DO i=1,req%size 510 502 ind_glo=req%src_domain(i) 511 503 nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1 512 504 ENDDO 513 505 514 506 DO ind_glo=1,ndomain_glo 515 507 IF ( nb_data_domain_recv(ind_glo) > 0 ) nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1 … … 532 524 ENDIF 533 525 ENDDO 534 526 535 527 req%recv(:)%size=0 536 528 irecv=0 … … 545 537 ENDDO 546 538 547 nb_domain_recv(:) = 0 539 nb_domain_recv(:) = 0 548 540 DO ind_loc=1,ndomain 549 541 req=>request(ind_loc) 550 542 551 543 DO irecv=1,req%nrecv 552 544 rank=req%recv(irecv)%rank … … 554 546 ENDDO 555 547 ENDDO 556 557 CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr) 558 548 549 CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr) 550 559 551 560 552 ALLOCATE(list_domain_send(sum(nb_domain_send))) 561 553 562 554 nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:)) 563 555 ALLOCATE(mpi_req(nreq)) 564 556 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 565 557 566 558 567 559 ireq=0 … … 575 567 ENDDO 576 568 577 IF (debug) PRINT *,"------------" 569 IF (debug) PRINT *,"------------" 578 570 j=0 579 571 DO rank=0,mpi_size-1 … … 585 577 ENDDO 586 578 ENDDO 587 IF (debug) PRINT *,"------------" 588 579 IF (debug) PRINT *,"------------" 580 589 581 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 590 582 591 583 list_domain(:)=0 592 584 DO i=1,sum(nb_domain_send) … … 594 586 list_domain(ind_loc)=list_domain(ind_loc)+1 595 587 ENDDO 596 588 597 589 DO ind_loc=1,ndomain 598 590 req=>request(ind_loc) … … 601 593 ENDDO 602 594 603 IF (debug) PRINT *,"------------" 604 605 ireq=0 595 IF (debug) PRINT *,"------------" 596 597 ireq=0 606 598 DO ind_loc=1,ndomain 607 599 req=>request(ind_loc) 608 600 609 601 DO irecv=1,req%nrecv 610 602 ireq=ireq+1 … … 612 604 IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 613 605 ENDDO 614 IF (debug) PRINT *,"------------" 615 606 IF (debug) PRINT *,"------------" 607 616 608 DO isend=1,req%nsend 617 609 ireq=ireq+1 … … 621 613 ENDDO 622 614 623 IF (debug) PRINT *,"------------" 615 IF (debug) PRINT *,"------------" 624 616 625 617 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 626 618 CALL MPI_BARRIER(comm_icosa,ierr) 627 619 628 IF (debug) PRINT *,"------------" 629 630 ireq=0 620 IF (debug) PRINT *,"------------" 621 622 ireq=0 631 623 DO ind_loc=1,ndomain 632 624 req=>request(ind_loc) 633 625 634 626 DO irecv=1,req%nrecv 635 627 ireq=ireq+1 … … 638 630 ENDDO 639 631 640 IF (debug) PRINT *,"------------" 641 632 IF (debug) PRINT *,"------------" 633 642 634 DO isend=1,req%nsend 643 635 ireq=ireq+1 … … 646 638 ENDDO 647 639 ENDDO 648 IF (debug) PRINT *,"------------" 649 640 IF (debug) PRINT *,"------------" 641 650 642 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 651 643 CALL MPI_BARRIER(comm_icosa,ierr) 652 IF (debug) PRINT *,"------------" 644 IF (debug) PRINT *,"------------" 653 645 654 646 ireq=0 655 647 DO ind_loc=1,ndomain 656 648 req=>request(ind_loc) 657 649 658 650 DO irecv=1,req%nrecv 659 651 ireq=ireq+1 … … 663 655 IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 664 656 ENDDO 665 IF (debug) PRINT *,"------------" 666 657 IF (debug) PRINT *,"------------" 658 667 659 DO isend=1,req%nsend 668 660 ireq=ireq+1 … … 671 663 ENDDO 672 664 ENDDO 673 IF (debug) PRINT *,"------------" 674 665 IF (debug) PRINT *,"------------" 666 675 667 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 676 668 CALL MPI_BARRIER(comm_icosa,ierr) 677 669 678 670 679 IF (debug) PRINT *,"------------" 680 681 ireq=0 671 IF (debug) PRINT *,"------------" 672 673 ireq=0 682 674 DO ind_loc=1,ndomain 683 675 req=>request(ind_loc) 684 676 685 677 DO irecv=1,req%nrecv 686 678 ireq=ireq+1 … … 688 680 IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 689 681 ENDDO 690 IF (debug) PRINT *,"------------" 691 682 IF (debug) PRINT *,"------------" 683 692 684 DO isend=1,req%nsend 693 685 ireq=ireq+1 … … 699 691 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 700 692 701 ireq=0 693 ireq=0 702 694 DO ind_loc=1,ndomain 703 695 req=>request(ind_loc) 704 696 705 697 DO irecv=1,req%nrecv 706 698 ireq=ireq+1 … … 708 700 req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 709 701 ENDDO 710 702 711 703 DO isend=1,req%nsend 712 704 ireq=ireq+1 … … 721 713 DO ind_loc=1,ndomain 722 714 req=>request(ind_loc) 723 715 724 716 DO irecv=1,req%nrecv 725 717 req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:) … … 727 719 DEALLOCATE(req%recv(irecv)%buffer) 728 720 ENDDO 729 ENDDO 730 721 ENDDO 722 731 723 732 724 ! domain is on the same mpi process => copie memory to memory 733 725 734 726 DO ind_loc=1,ndomain 735 727 req=>request(ind_loc) 736 728 737 729 DO irecv=1,req%nrecv 738 730 739 731 IF (req%recv(irecv)%rank==mpi_rank) THEN 740 732 req_src=>request(req%recv(irecv)%domain) … … 749 741 ENDDO 750 742 ENDIF 751 743 752 744 ENDDO 753 745 ENDDO 754 746 755 747 ! true number of mpi request 756 748 … … 761 753 ALLOCATE(offset(sum(request(:)%nsend))) 762 754 offset(:)=0 763 755 764 756 nsend=0 765 757 DO ind_loc=1,ndomain … … 773 765 pos=pos+1 774 766 ENDDO 775 767 776 768 IF (pos==nsend) THEN 777 769 nsend=nsend+1 … … 784 776 ENDIF 785 777 ENDIF 786 778 787 779 pos=pos+1 788 780 req%send(isend)%ireq=pos … … 795 787 DEALLOCATE(rank_list) 796 788 DEALLOCATE(offset) 797 789 798 790 ALLOCATE(rank_list(sum(request(:)%nrecv))) 799 791 ALLOCATE(offset(sum(request(:)%nrecv))) 800 792 offset(:)=0 801 793 802 794 nrecv=0 803 795 DO ind_loc=1,ndomain … … 811 803 pos=pos+1 812 804 ENDDO 813 805 814 806 IF (pos==nrecv) THEN 815 807 nrecv=nrecv+1 … … 822 814 ENDIF 823 815 ENDIF 824 816 825 817 pos=pos+1 826 818 req%recv(irecv)%ireq=nsend+pos … … 829 821 ENDIF 830 822 ENDDO 831 ENDDO 832 833 ! get the offsets 834 835 ireq=0 823 ENDDO 824 825 ! get the offsets 826 827 ireq=0 836 828 DO ind_loc=1,ndomain 837 829 req=>request(ind_loc) 838 830 839 831 DO irecv=1,req%nrecv 840 832 ireq=ireq+1 … … 842 834 req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 843 835 ENDDO 844 836 845 837 DO isend=1,req%nsend 846 838 ireq=ireq+1 … … 851 843 852 844 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 853 854 855 END SUBROUTINE Finalize_request 845 846 847 END SUBROUTINE Finalize_request 856 848 857 849 … … 867 859 TYPE(t_message) :: message 868 860 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name 869 !$OMP MASTER 861 !$OMP MASTER 870 862 message%request=>request 871 863 IF(PRESENT(name)) THEN … … 874 866 message%name = 'unknown' 875 867 END IF 876 !$OMP END MASTER 877 !$OMP BARRIER 868 !$OMP END MASTER 869 !$OMP BARRIER 878 870 879 871 END SUBROUTINE init_message_seq … … 891 883 892 884 CALL transfert_request_seq(field,message%request) 893 885 894 886 END SUBROUTINE send_message_seq 895 887 896 888 SUBROUTINE test_message_seq(message) 897 889 IMPLICIT NONE 898 890 TYPE(t_message) :: message 899 891 END SUBROUTINE test_message_seq 900 901 892 893 902 894 SUBROUTINE wait_message_seq(message) 903 895 IMPLICIT NONE 904 896 TYPE(t_message) :: message 905 906 END SUBROUTINE wait_message_seq 907 908 SUBROUTINE transfert_message_seq(field,message) 909 USE field_mod 910 USE domain_mod 911 USE mpi_mod 912 USE mpipara 913 USE omp_para 914 USE trace 915 IMPLICIT NONE 916 TYPE(t_field),POINTER :: field(:) 917 TYPE(t_message) :: message 918 919 CALL send_message_seq(field,message) 920 921 END SUBROUTINE transfert_message_seq 922 923 924 925 897 898 END SUBROUTINE wait_message_seq 899 926 900 SUBROUTINE init_message_mpi(field,request, message, name) 927 901 USE field_mod … … 931 905 USE mpi_mod 932 906 IMPLICIT NONE 933 907 934 908 TYPE(t_field),POINTER :: field(:) 935 909 TYPE(t_request),POINTER :: request(:) … … 960 934 IF (message_number==100) message_number=0 961 935 962 936 963 937 message%request=>request 964 938 message%nreq=sum(message%request(:)%nreq_mpi) … … 979 953 DO isend=1,req%nsend 980 954 IF (req%send(isend)%rank/=mpi_rank) THEN 981 ireq=req%send(isend)%ireq 955 ireq=req%send(isend)%ireq 982 956 message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size 983 957 message%buffers(ireq)%rank=req%send(isend)%rank … … 986 960 DO irecv=1,req%nrecv 987 961 IF (req%recv(irecv)%rank/=mpi_rank) THEN 988 ireq=req%recv(irecv)%ireq 962 ireq=req%recv(irecv)%ireq 989 963 message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size 990 964 message%buffers(ireq)%rank=req%recv(irecv)%rank … … 997 971 998 972 IF (field(1)%ndim==2) THEN 999 973 1000 974 DO ireq=1,message%nreq 1001 975 CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 1002 976 ENDDO 1003 977 1004 978 ELSE IF (field(1)%ndim==3) THEN 1005 979 1006 980 dim3=size(field(1)%rval3d,2) 1007 981 DO ireq=1,message%nreq … … 1009 983 CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 1010 984 ENDDO 1011 985 1012 986 ELSE IF (field(1)%ndim==4) THEN 1013 987 dim3=size(field(1)%rval4d,2) … … 1017 991 CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 1018 992 ENDDO 1019 ENDIF 993 ENDIF 1020 994 ENDIF 1021 1022 1023 995 996 997 1024 998 ! ! Reorder the request, so recv request are done in the same order than send request 1025 999 1026 ! nreq_send=sum(request(:)%nsend) 1000 ! nreq_send=sum(request(:)%nsend) 1027 1001 ! message%nreq_send=nreq_send 1028 1002 ! ALLOCATE(message%reorder(nreq_send)) … … 1050 1024 ! ENDDO 1051 1025 ! PRINT *,"reorder ",reorder(:)%tag 1052 1053 1026 1027 1054 1028 !$OMP END MASTER 1055 !$OMP BARRIER 1029 !$OMP BARRIER 1056 1030 1057 1031 END SUBROUTINE init_message_mpi 1058 1059 SUBROUTINE Finalize_message_mpi( field,message)1032 1033 SUBROUTINE Finalize_message_mpi(message) 1060 1034 USE field_mod 1061 1035 USE domain_mod … … 1064 1038 USE mpi_mod 1065 1039 IMPLICIT NONE 1066 TYPE(t_field),POINTER :: field(:)1067 1040 TYPE(t_message) :: message 1068 1041 … … 1076 1049 DO ireq=1,message%nreq 1077 1050 CALL free_mpi_buffer(message%buffers(ireq)%r) 1078 ENDDO 1051 ENDDO 1079 1052 ENDIF 1080 1053 … … 1110 1083 !$OMP BARRIER 1111 1084 1112 1085 1113 1086 END SUBROUTINE Finalize_message_mpi 1114 1115 1116 1117 SUBROUTINE barrier1118 USE mpi_mod1119 USE mpipara1120 IMPLICIT NONE1121 1122 CALL MPI_BARRIER(comm_icosa,ierr)1123 1124 END SUBROUTINE barrier1125 1126 SUBROUTINE transfert_message_mpi(field,message)1127 USE field_mod1128 IMPLICIT NONE1129 TYPE(t_field),POINTER :: field(:)1130 TYPE(t_message) :: message1131 1132 CALL send_message_mpi(field,message)1133 CALL wait_message_mpi(message)1134 1135 END SUBROUTINE transfert_message_mpi1136 1087 1137 1088 … … 1184 1135 TYPE(t_field),POINTER :: field(:) 1185 1136 TYPE(t_message) :: message 1186 REAL(rstd),POINTER :: rval2d(:), src_rval2d(:) 1187 REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:) 1188 REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:) 1189 REAL(rstd),POINTER :: buffer_r(:) 1190 INTEGER,POINTER :: value(:) 1191 INTEGER,POINTER :: sgn(:) 1192 TYPE(ARRAY),POINTER :: recv,send 1137 REAL(rstd),POINTER :: rval2d(:), src_rval2d(:) 1138 REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:) 1139 REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:) 1140 REAL(rstd),POINTER :: buffer_r(:) 1141 INTEGER,POINTER :: value(:) 1142 INTEGER,POINTER :: sgn(:) 1143 TYPE(ARRAY),POINTER :: recv,send 1193 1144 TYPE(t_request),POINTER :: req 1194 1145 INTEGER :: irecv,isend … … 1240 1191 DO ind=1,ndomain 1241 1192 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1242 1193 1243 1194 rval2d=>field(ind)%rval2d 1244 1195 1245 1196 req=>message%request(ind) 1246 1197 DO isend=1,req%nsend … … 1248 1199 value=>send%value 1249 1200 1250 1201 1251 1202 IF (send%rank/=mpi_rank) THEN 1252 1203 ireq=send%ireq … … 1264 1215 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1265 1216 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1266 !$OMP CRITICAL 1217 !$OMP CRITICAL 1267 1218 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, & 1268 1219 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) … … 1273 1224 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1274 1225 ENDIF 1275 1226 1276 1227 ENDIF 1277 1228 ENDDO 1278 1229 ENDDO 1279 1230 1280 1231 DO ind=1,ndomain 1281 1232 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1282 1233 rval2d=>field(ind)%rval2d 1283 req=>message%request(ind) 1234 req=>message%request(ind) 1284 1235 1285 1236 DO irecv=1,req%nrecv … … 1301 1252 1302 1253 ELSE 1303 1254 1304 1255 ireq=recv%ireq 1305 1256 buffer_r=>message%buffers(ireq)%r 1306 1257 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1307 1258 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1308 !$OMP CRITICAL 1259 !$OMP CRITICAL 1309 1260 CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, & 1310 1261 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) … … 1315 1266 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1316 1267 ENDIF 1317 1268 1318 1269 ENDIF 1319 1270 ENDDO 1320 1271 1321 1272 ENDDO 1322 1323 1273 1274 1324 1275 ELSE IF (field(1)%ndim==3) THEN 1325 1276 max_req=0 … … 1328 1279 IF (req%nsend>max_req) max_req=req%nsend 1329 1280 ENDDO 1330 1281 1331 1282 DO ind=1,ndomain 1332 1283 IF (.NOT. assigned_domain(ind) ) CYCLE … … 1337 1288 rval3d=>field(ind)%rval3d 1338 1289 req=>message%request(ind) 1339 1290 1340 1291 DO isend=1,req%nsend 1341 1292 send=>req%send(isend) … … 1366 1317 1367 1318 ENDIF 1368 1319 1369 1320 IF (is_omp_level_master) THEN 1370 1321 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1371 1322 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1372 !$OMP CRITICAL 1323 !$OMP CRITICAL 1373 1324 CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, & 1374 1325 send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) … … 1400 1351 1401 1352 ENDDO 1402 1353 1403 1354 DO ind=1,ndomain 1404 1355 IF (.NOT. assigned_domain(ind) ) CYCLE … … 1432 1383 ireq=recv%ireq 1433 1384 buffer_r=>message%buffers(ireq)%r 1434 1385 1435 1386 IF (is_omp_level_master) THEN 1436 1387 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN … … 1446 1397 ENDIF 1447 1398 ENDIF 1448 ENDIF 1399 ENDIF 1449 1400 ENDDO 1450 1401 1451 1402 ENDDO 1452 1403 … … 1458 1409 IF (req%nsend>max_req) max_req=req%nsend 1459 1410 ENDDO 1460 1411 1461 1412 DO ind=1,ndomain 1462 1413 IF (.NOT. assigned_domain(ind) ) CYCLE … … 1524 1475 ENDIF 1525 1476 ENDDO 1526 1477 1527 1478 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 1528 1479 DO isend=req%nsend+1,max_req … … 1535 1486 1536 1487 ENDDO 1537 1488 1538 1489 DO ind=1,ndomain 1539 1490 IF (.NOT. assigned_domain(ind) ) CYCLE 1540 1491 1541 1492 dim3=size(field(ind)%rval4d,2) 1542 1493 CALL distrib_level(1,dim3, lbegin,lend) … … 1565 1516 call exit_profile(profile_mpi_copies) 1566 1517 CALL trace_end("copy_data") 1567 1518 1568 1519 ELSE 1569 1520 … … 1573 1524 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 1574 1525 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 1575 !$OMP CRITICAL 1526 !$OMP CRITICAL 1576 1527 CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank, & 1577 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1528 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1578 1529 !$OMP END CRITICAL 1579 1530 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 1580 1531 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 1581 1532 CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank, & 1582 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1533 recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 1583 1534 ENDIF 1584 1535 ENDIF … … 1587 1538 ENDDO 1588 1539 1589 ENDIF 1540 ENDIF 1590 1541 1591 1542 IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN … … 1629 1580 1630 1581 !$OMP END MASTER 1631 ENDIF 1582 ENDIF 1632 1583 ENDIF 1633 1584 CALL enter_profile(profile_mpi_omp_barrier) … … 1638 1589 1639 1590 CALL exit_profile(id_mpi) 1640 1591 1641 1592 END SUBROUTINE send_message_mpi 1642 1593 1643 1594 SUBROUTINE test_message_mpi(message) 1644 1595 IMPLICIT NONE 1645 1596 TYPE(t_message) :: message 1646 1597 1647 1598 INTEGER :: ierr 1648 1599 … … 1652 1603 !$OMP END MASTER 1653 1604 END SUBROUTINE test_message_mpi 1654 1655 1605 1606 1656 1607 SUBROUTINE wait_message_mpi(message) 1657 1608 USE profiling_mod … … 1666 1617 1667 1618 TYPE(t_field),POINTER :: field(:) 1668 REAL(rstd),POINTER :: rval2d(:) 1669 REAL(rstd),POINTER :: rval3d(:,:) 1670 REAL(rstd),POINTER :: rval4d(:,:,:) 1671 REAL(rstd),POINTER :: buffer_r(:) 1672 INTEGER,POINTER :: value(:) 1673 INTEGER,POINTER :: sgn(:) 1674 TYPE(ARRAY),POINTER :: recv 1619 REAL(rstd),POINTER :: rval2d(:) 1620 REAL(rstd),POINTER :: rval3d(:,:) 1621 REAL(rstd),POINTER :: rval4d(:,:,:) 1622 REAL(rstd),POINTER :: buffer_r(:) 1623 INTEGER,POINTER :: value(:) 1624 INTEGER,POINTER :: sgn(:) 1625 TYPE(ARRAY),POINTER :: recv 1675 1626 TYPE(t_request),POINTER :: req 1676 1627 INTEGER :: irecv … … 1689 1640 field=>message%field 1690 1641 nreq=message%nreq 1691 1642 1692 1643 IF (field(1)%data_type==type_real) THEN 1693 1644 IF (field(1)%ndim==2) THEN … … 1703 1654 DO ind=1,ndomain 1704 1655 IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 1705 1656 1706 1657 rval2d=>field(ind)%rval2d 1707 1658 req=>message%request(ind) … … 1717 1668 !$acc parallel loop default(present) async if (field(ind)%ondevice) 1718 1669 DO n=1,msize 1719 rval2d(value(n))=buffer_r(n+offset)*sgn(n) 1670 rval2d(value(n))=buffer_r(n+offset)*sgn(n) 1720 1671 ENDDO 1721 1672 1722 1673 ENDIF 1723 1674 ENDDO 1724 1675 1725 1676 ENDDO 1726 1677 call exit_profile(profile_mpi_copies) … … 1736 1687 call exit_profile(profile_mpi_waitall) 1737 1688 1738 1689 1739 1690 DO ind=1,ndomain 1740 1691 IF (.NOT. assigned_domain(ind) ) CYCLE … … 1749 1700 value=>recv%value 1750 1701 sgn=>recv%sign 1751 1702 1752 1703 dim3=size(rval3d,2) 1753 1704 1754 1705 CALL distrib_level(1,dim3, lbegin,lend) 1755 1706 msize=recv%size … … 1757 1708 call enter_profile(profile_mpi_copies) 1758 1709 CALL trace_start("copy_from_buffer") 1759 1710 1760 1711 IF (req%vector) THEN 1761 1712 !$acc parallel loop default(present) async if (field(ind)%ondevice) … … 1764 1715 !$acc loop 1765 1716 DO n=1,msize 1766 rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n) 1717 rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n) 1767 1718 ENDDO 1768 1719 ENDDO … … 1773 1724 !$acc loop 1774 1725 DO n=1,msize 1775 rval3d(value(n),d3)=buffer_r(n+offset) 1726 rval3d(value(n),d3)=buffer_r(n+offset) 1776 1727 ENDDO 1777 1728 ENDDO 1778 1729 ENDIF 1779 1730 1780 1731 CALL trace_end("copy_from_buffer") 1781 1732 call exit_profile(profile_mpi_copies) 1782 1733 ENDIF 1783 1734 ENDDO 1784 1735 1785 1736 ENDDO 1786 1737 … … 1794 1745 call exit_profile(profile_mpi_waitall) 1795 1746 1796 1747 1797 1748 DO ind=1,ndomain 1798 1749 IF (.NOT. assigned_domain(ind) ) CYCLE … … 1822 1773 !$acc loop 1823 1774 DO n=1,msize 1824 rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n) 1775 rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n) 1825 1776 ENDDO 1826 1777 ENDDO … … 1830 1781 ENDIF 1831 1782 ENDDO 1832 1783 1833 1784 ENDDO 1834 1835 ENDIF 1836 1785 1786 ENDIF 1787 1837 1788 ENDIF 1838 1789 … … 1843 1794 ! CALL trace_end("wait_message_mpi") 1844 1795 !$OMP BARRIER 1845 1796 1846 1797 CALL exit_profile(id_mpi) 1847 1798 1848 1799 END SUBROUTINE wait_message_mpi 1849 1800 1850 SUBROUTINE transfert_request_mpi(field,request) 1851 USE field_mod 1852 IMPLICIT NONE 1853 TYPE(t_field),POINTER :: field(:) 1854 TYPE(t_request),POINTER :: request(:) 1855 1856 TYPE(t_message),SAVE :: message 1857 1858 1859 CALL init_message_mpi(field,request, message) 1860 CALL transfert_message_mpi(field,message) 1861 CALL finalize_message_mpi(field,message) 1862 1863 END SUBROUTINE transfert_request_mpi 1864 1865 1866 1801 1867 1802 SUBROUTINE transfert_request_seq(field,request) 1868 1803 USE field_mod … … 1871 1806 TYPE(t_field),POINTER :: field(:) 1872 1807 TYPE(t_request),POINTER :: request(:) 1873 REAL(rstd),POINTER :: rval2d(:) 1874 REAL(rstd),POINTER :: rval3d(:,:) 1875 REAL(rstd),POINTER :: rval4d(:,:,:) 1808 REAL(rstd),POINTER :: rval2d(:) 1809 REAL(rstd),POINTER :: rval3d(:,:) 1810 REAL(rstd),POINTER :: rval4d(:,:,:) 1876 1811 INTEGER :: ind 1877 1812 TYPE(t_request),POINTER :: req 1878 1813 INTEGER :: n 1879 1814 1880 1815 DO ind=1,ndomain 1881 1816 req=>request(ind) … … 1883 1818 rval3d=>field(ind)%rval3d 1884 1819 rval4d=>field(ind)%rval4d 1885 1820 1886 1821 IF (field(ind)%data_type==type_real) THEN 1887 1822 IF (field(ind)%ndim==2) THEN … … 1901 1836 ENDDO 1902 1837 ENDIF 1903 ENDIF 1838 ENDIF 1904 1839 1905 1840 ENDDO 1906 1841 1907 1842 END SUBROUTINE transfert_request_seq 1908 1909 1910 SUBROUTINE gather_field(field_loc,field_glo) 1911 USE field_mod 1912 USE domain_mod 1913 USE mpi_mod 1914 USE mpipara 1915 IMPLICIT NONE 1916 TYPE(t_field),POINTER :: field_loc(:) 1917 TYPE(t_field),POINTER :: field_glo(:) 1918 INTEGER, ALLOCATABLE :: mpi_req(:) 1919 INTEGER, ALLOCATABLE :: status(:,:) 1920 INTEGER :: ireq,nreq 1921 INTEGER :: ind_glo,ind_loc 1922 1923 IF (.NOT. using_mpi) THEN 1924 1925 DO ind_loc=1,ndomain 1926 IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d 1927 IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d 1928 IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d 1929 ENDDO 1930 1931 ELSE 1932 1933 nreq=ndomain 1934 IF (mpi_rank==0) nreq=nreq+ndomain_glo 1935 ALLOCATE(mpi_req(nreq)) 1936 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 1937 1938 1939 ireq=0 1940 IF (mpi_rank==0) THEN 1941 DO ind_glo=1,ndomain_glo 1942 ireq=ireq+1 1943 1944 IF (field_glo(ind_glo)%ndim==2) THEN 1945 CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , & 1946 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1947 1948 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 1949 CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , & 1950 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1951 1952 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 1953 CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , & 1954 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 1955 ENDIF 1956 1957 ENDDO 1958 ENDIF 1959 1960 DO ind_loc=1,ndomain 1961 ireq=ireq+1 1962 1963 IF (field_loc(ind_loc)%ndim==2) THEN 1964 CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , & 1965 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1966 ELSE IF (field_loc(ind_loc)%ndim==3) THEN 1967 CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , & 1968 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1969 ELSE IF (field_loc(ind_loc)%ndim==4) THEN 1970 CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , & 1971 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 1972 ENDIF 1973 1974 ENDDO 1975 1976 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 1977 1978 ENDIF 1979 1980 END SUBROUTINE gather_field 1981 1982 SUBROUTINE bcast_field(field_glo) 1983 USE field_mod 1984 USE domain_mod 1985 USE mpi_mod 1986 USE mpipara 1987 IMPLICIT NONE 1988 TYPE(t_field),POINTER :: field_glo(:) 1989 INTEGER :: ind_glo 1990 1991 IF (.NOT. using_mpi) THEN 1992 1993 ! nothing to do 1994 1995 ELSE 1996 1997 DO ind_glo=1,ndomain_glo 1998 1999 IF (field_glo(ind_glo)%ndim==2) THEN 2000 CALL MPI_BCAST(field_glo(ind_glo)%rval2d, size(field_glo(ind_glo)%rval2d) , MPI_REAL8, 0, comm_icosa, ierr) 2001 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 2002 CALL MPI_BCAST(field_glo(ind_glo)%rval3d, size(field_glo(ind_glo)%rval3d) , MPI_REAL8, 0, comm_icosa, ierr) 2003 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 2004 CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr) 2005 ENDIF 2006 2007 ENDDO 2008 ENDIF 2009 2010 END SUBROUTINE bcast_field 2011 2012 SUBROUTINE scatter_field(field_glo,field_loc) 2013 USE field_mod 2014 USE domain_mod 2015 USE mpi_mod 2016 USE mpipara 2017 IMPLICIT NONE 2018 TYPE(t_field),POINTER :: field_glo(:) 2019 TYPE(t_field),POINTER :: field_loc(:) 2020 INTEGER, ALLOCATABLE :: mpi_req(:) 2021 INTEGER, ALLOCATABLE :: status(:,:) 2022 INTEGER :: ireq,nreq 2023 INTEGER :: ind_glo,ind_loc 2024 2025 IF (.NOT. using_mpi) THEN 2026 2027 DO ind_loc=1,ndomain 2028 IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d 2029 IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d 2030 IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 2031 ENDDO 2032 2033 ELSE 2034 2035 nreq=ndomain 2036 IF (mpi_rank==0) nreq=nreq+ndomain_glo 2037 ALLOCATE(mpi_req(nreq)) 2038 ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 2039 2040 2041 ireq=0 2042 IF (mpi_rank==0) THEN 2043 DO ind_glo=1,ndomain_glo 2044 ireq=ireq+1 2045 2046 IF (field_glo(ind_glo)%ndim==2) THEN 2047 CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , & 2048 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 2049 2050 ELSE IF (field_glo(ind_glo)%ndim==3) THEN 2051 CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , & 2052 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 2053 2054 ELSE IF (field_glo(ind_glo)%ndim==4) THEN 2055 CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , & 2056 domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 2057 ENDIF 2058 2059 ENDDO 2060 ENDIF 2061 2062 DO ind_loc=1,ndomain 2063 ireq=ireq+1 2064 2065 IF (field_loc(ind_loc)%ndim==2) THEN 2066 CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , & 2067 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 2068 ELSE IF (field_loc(ind_loc)%ndim==3) THEN 2069 CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , & 2070 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 2071 ELSE IF (field_loc(ind_loc)%ndim==4) THEN 2072 CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , & 2073 0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 2074 ENDIF 2075 2076 ENDDO 2077 2078 CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 2079 2080 ENDIF 2081 2082 END SUBROUTINE scatter_field 2083 2084 SUBROUTINE trace_in 2085 USE trace 2086 IMPLICIT NONE 2087 2088 CALL trace_start("transfert_buffer") 2089 END SUBROUTINE trace_in 2090 2091 SUBROUTINE trace_out 2092 USE trace 2093 IMPLICIT NONE 2094 2095 CALL trace_end("transfert_buffer") 2096 END SUBROUTINE trace_out 2097 2098 2099 2100 2101 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2102 !! Definition des Broadcast --> 4D !! 2103 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2104 2105 !! -- Les chaine de charactï¿œre -- !! 2106 2107 SUBROUTINE bcast_mpi_c(var1) 2108 IMPLICIT NONE 2109 CHARACTER(LEN=*),INTENT(INOUT) :: Var1 2110 2111 CALL bcast_mpi_cgen(Var1,len(Var1)) 2112 2113 END SUBROUTINE bcast_mpi_c 2114 2115 !! -- Les entiers -- !! 2116 2117 SUBROUTINE bcast_mpi_i(var) 2118 USE mpipara 2119 IMPLICIT NONE 2120 INTEGER,INTENT(INOUT) :: Var 2121 2122 INTEGER :: var_tmp(1) 2123 2124 IF (is_mpi_master) var_tmp(1)=var 2125 CALL bcast_mpi_igen(Var_tmp,1) 2126 var=var_tmp(1) 2127 2128 END SUBROUTINE bcast_mpi_i 2129 2130 SUBROUTINE bcast_mpi_i1(var) 2131 IMPLICIT NONE 2132 INTEGER,INTENT(INOUT) :: Var(:) 2133 2134 CALL bcast_mpi_igen(Var,size(Var)) 2135 2136 END SUBROUTINE bcast_mpi_i1 2137 2138 SUBROUTINE bcast_mpi_i2(var) 2139 IMPLICIT NONE 2140 INTEGER,INTENT(INOUT) :: Var(:,:) 2141 2142 CALL bcast_mpi_igen(Var,size(Var)) 2143 2144 END SUBROUTINE bcast_mpi_i2 2145 2146 SUBROUTINE bcast_mpi_i3(var) 2147 IMPLICIT NONE 2148 INTEGER,INTENT(INOUT) :: Var(:,:,:) 2149 2150 CALL bcast_mpi_igen(Var,size(Var)) 2151 2152 END SUBROUTINE bcast_mpi_i3 2153 2154 SUBROUTINE bcast_mpi_i4(var) 2155 IMPLICIT NONE 2156 INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 2157 2158 CALL bcast_mpi_igen(Var,size(Var)) 2159 2160 END SUBROUTINE bcast_mpi_i4 2161 2162 2163 !! -- Les reels -- !! 2164 2165 SUBROUTINE bcast_mpi_r(var) 2166 USE mpipara 2167 IMPLICIT NONE 2168 REAL,INTENT(INOUT) :: Var 2169 REAL :: var_tmp(1) 2170 2171 IF (is_mpi_master) var_tmp(1)=var 2172 CALL bcast_mpi_rgen(Var_tmp,1) 2173 var=var_tmp(1) 2174 2175 END SUBROUTINE bcast_mpi_r 2176 2177 SUBROUTINE bcast_mpi_r1(var) 2178 IMPLICIT NONE 2179 REAL,INTENT(INOUT) :: Var(:) 2180 2181 CALL bcast_mpi_rgen(Var,size(Var)) 2182 2183 END SUBROUTINE bcast_mpi_r1 2184 2185 SUBROUTINE bcast_mpi_r2(var) 2186 IMPLICIT NONE 2187 REAL,INTENT(INOUT) :: Var(:,:) 2188 2189 CALL bcast_mpi_rgen(Var,size(Var)) 2190 2191 END SUBROUTINE bcast_mpi_r2 2192 2193 SUBROUTINE bcast_mpi_r3(var) 2194 IMPLICIT NONE 2195 REAL,INTENT(INOUT) :: Var(:,:,:) 2196 2197 CALL bcast_mpi_rgen(Var,size(Var)) 2198 2199 END SUBROUTINE bcast_mpi_r3 2200 2201 SUBROUTINE bcast_mpi_r4(var) 2202 IMPLICIT NONE 2203 REAL,INTENT(INOUT) :: Var(:,:,:,:) 2204 2205 CALL bcast_mpi_rgen(Var,size(Var)) 2206 2207 END SUBROUTINE bcast_mpi_r4 2208 2209 !! -- Les booleans -- !! 2210 2211 SUBROUTINE bcast_mpi_l(var) 2212 USE mpipara 2213 IMPLICIT NONE 2214 LOGICAL,INTENT(INOUT) :: Var 2215 LOGICAL :: var_tmp(1) 2216 2217 IF (is_mpi_master) var_tmp(1)=var 2218 CALL bcast_mpi_lgen(Var_tmp,1) 2219 var=var_tmp(1) 2220 2221 END SUBROUTINE bcast_mpi_l 2222 2223 SUBROUTINE bcast_mpi_l1(var) 2224 IMPLICIT NONE 2225 LOGICAL,INTENT(INOUT) :: Var(:) 2226 2227 CALL bcast_mpi_lgen(Var,size(Var)) 2228 2229 END SUBROUTINE bcast_mpi_l1 2230 2231 SUBROUTINE bcast_mpi_l2(var) 2232 IMPLICIT NONE 2233 LOGICAL,INTENT(INOUT) :: Var(:,:) 2234 2235 CALL bcast_mpi_lgen(Var,size(Var)) 2236 2237 END SUBROUTINE bcast_mpi_l2 2238 2239 SUBROUTINE bcast_mpi_l3(var) 2240 IMPLICIT NONE 2241 LOGICAL,INTENT(INOUT) :: Var(:,:,:) 2242 2243 CALL bcast_mpi_lgen(Var,size(Var)) 2244 2245 END SUBROUTINE bcast_mpi_l3 2246 2247 SUBROUTINE bcast_mpi_l4(var) 2248 IMPLICIT NONE 2249 LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 2250 2251 CALL bcast_mpi_lgen(Var,size(Var)) 2252 2253 END SUBROUTINE bcast_mpi_l4 2254 2255 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2256 !! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! 2257 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2258 2259 SUBROUTINE bcast_mpi_cgen(var,nb) 2260 USE mpi_mod 2261 USE mpipara 2262 IMPLICIT NONE 2263 2264 CHARACTER(LEN=*),INTENT(INOUT) :: Var 2265 INTEGER,INTENT(IN) :: nb 2266 2267 IF (.NOT. using_mpi) RETURN 2268 2269 CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr) 2270 2271 END SUBROUTINE bcast_mpi_cgen 2272 2273 2274 2275 SUBROUTINE bcast_mpi_igen(var,nb) 2276 USE mpi_mod 2277 USE mpipara 2278 IMPLICIT NONE 2279 INTEGER,INTENT(IN) :: nb 2280 INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var 2281 2282 IF (.NOT. using_mpi) RETURN 2283 2284 CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr) 2285 2286 END SUBROUTINE bcast_mpi_igen 2287 2288 2289 2290 2291 SUBROUTINE bcast_mpi_rgen(var,nb) 2292 USE mpi_mod 2293 USE mpipara 2294 IMPLICIT NONE 2295 INTEGER,INTENT(IN) :: nb 2296 REAL,DIMENSION(nb),INTENT(INOUT) :: Var 2297 2298 IF (.NOT. using_mpi) RETURN 2299 2300 CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr) 2301 2302 END SUBROUTINE bcast_mpi_rgen 2303 2304 2305 2306 2307 SUBROUTINE bcast_mpi_lgen(var,nb) 2308 USE mpi_mod 2309 USE mpipara 2310 IMPLICIT NONE 2311 INTEGER,INTENT(IN) :: nb 2312 LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var 2313 2314 IF (.NOT. using_mpi) RETURN 2315 2316 CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr) 2317 2318 END SUBROUTINE bcast_mpi_lgen 2319 2320 2321 END MODULE transfert_mpi_mod 2322 2323 2324 2325 2326 1843 1844 1845 END MODULE transfert_mpi_legacy_mod 1846 1847 1848 1849 1850 -
codes/icosagcm/trunk/src/sphere/geometry.f90
r953 r963 360 360 USE dimensions 361 361 USE domain_mod 362 USE transfert_m pi_mod362 USE transfert_mod 363 363 364 364 INTEGER :: ind,i,j,k,n … … 384 384 CALL allocate_field_glo(xyz_glo, field_t, type_real, 3) 385 385 CALL allocate_field_glo(vertex_glo, field_z, type_real, 3) 386 386 387 387 388 CALL gather_field(xyz_loc, xyz_glo) -
codes/icosagcm/trunk/src/transport/advect_tracer.F90
r954 r963 148 148 149 149 CALL send_message(f_cc,req_cc) 150 CALL wait_message(req_cc) 150 151 151 152 ! horizontal transport - split in two to place transfer of gradq3d … … 164 165 165 166 CALL send_message(f_gradq3d,req_gradq3d) 166 CALL wait_message(req_cc)167 167 CALL wait_message(req_gradq3d) 168 168
Note: See TracChangeset
for help on using the changeset viewer.