fiat-ecmwf-2.0.0/0000775000175000017500000000000015157200513013716 5ustar alastairalastairfiat-ecmwf-2.0.0/VERSION0000664000175000017500000000000615157200431014761 0ustar alastairalastair2.0.0 fiat-ecmwf-2.0.0/tests/0000775000175000017500000000000015157200431015057 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/scatterv.F900000664000175000017500000001514415157200431017177 0ustar alastairalastair!(C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Simple Test program ! subroutine fail_impl(msg,line) use mpl_module, only : mpl_abort character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in scatterv.F90 @ line ",line," :" write(0,*) msg call mpl_abort() end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) subroutine work1(r) implicit none integer, intent(out) :: r real a(100000) call random_number(a) if (any(a < 0.0) ) then r =1 else r =0 endif end subroutine work1 program test_mpl_scatterv use ec_parkind, only : jpim, jprm, jprd use mpl_module, only: mpl_init, mpl_end, mpl_rank, linitmpi_via_mpl, mpl_scatterv, JP_NON_BLOCKING_STANDARD, mpl_wait implicit none integer(jpim) :: nprocs call mpl_init(KPROCS=nprocs,ldinfo=.false.,ldenv=.true.) if( nprocs <= 1 ) FAIL("nprocs must be > 1") if( mpl_rank < 1 .or. mpl_rank > nprocs ) FAIL("mpl_rank must be >= 1 and <= nprocs") if( .not. linitmpi_via_mpl ) FAIL("linitmpi_via_mpl must be True") call do_scatterv("blocking") call do_scatterv("nonblocking") call mpl_end(ldmeminfo=.false.) ! Note that with mpi_serial meminfo will not be printed regardless of ldmeminfo contains subroutine do_scatterv(mode) implicit none character(len=*), intent(in) :: mode character(len=128) :: msg integer request_i, request_r, request_d, request_c, i, j, k, res integer sdispl(nprocs), rcounts_c(nprocs) integer(jpim), allocatable :: sbuf(:), rbuf(:), scounts(:) integer(jpim) :: rcounts real(jprm), allocatable :: sbufr(:), rbufr(:) real(jprd), allocatable :: sbufd(:), rbufd(:) integer kroot allocate(rbuf(mpl_rank),sbuf((nprocs*(nprocs+1))/2+nprocs),& rbufr(mpl_rank),sbufr((nprocs*(nprocs+1))/2+nprocs), & rbufd(mpl_rank),sbufd((nprocs*(nprocs+1))/2+nprocs),& scounts(nprocs)) k=1 do i=1,nprocs do j=0,i-1 sbuf(k+j)=i sbufr(k+j)=real(i) sbufd(k+j)=real(i,kind=jprd) enddo k=k+i enddo rcounts=mpl_rank do i=1,nprocs scounts(i)=i enddo kroot=2 select case(mode) case("blocking") call mpl_scatterv(rbuf,kroot,sbuf,scounts) call mpl_scatterv(rbufr,kroot,sbufr,scounts) if (mpl_rank == kroot) then call mpl_scatterv(rbufd,kroot,sbufd,scounts) else call mpl_scatterv(rbufd,kroot) endif case("nonblocking") ! trying to get a random failure do j=1,1 if (mpl_rank == kroot ) then call mpl_scatterv(rbuf,kroot,sbuf,scounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_scatterv(rbufr,kroot,sbufr,scounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_scatterv(rbufd,kroot,sbufd,scounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) else call mpl_scatterv(rbuf,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_scatterv(rbufr,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_scatterv(rbufd,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) endif call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_r) call mpl_wait(request_d) call mpl_wait(request_i) enddo end select ! test values if ( any(rbuf /= mpl_rank) ) then !write(0,*) 'send ', mpl_rank, scounts, sbuf !write(0,*) 'recv ', mpl_rank, rcounts, rdispl write(msg,*) trim(mode)//" int scatterv test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr) /= mpl_rank) ) then write(msg,*) trim(mode)//" real scatterv test failed on mpl_rank", mpl_rank, rbufr FAIL(msg) endif if ( any(nint(rbufd) /= mpl_rank) ) then write(msg,*) trim(mode)//" double scatterv test failed on mpl_rank", mpl_rank, rbufd FAIL(msg) endif ! test with displacement arguments k=1 do i=1,nprocs sbuf(k)=-1 sbufr(k)=-1.0 sbufd(k)=-1.0 do j=1,i sbuf(k+j)=i sbufr(k+j)=real(i) sbufd(k+j)=real(i,kind=jprd) enddo k=k+i+1 enddo rcounts=mpl_rank do i=1,nprocs scounts(i)=i sdispl(i)=sum(scounts(1:i-1)) + i enddo kroot=1 select case(mode) case("blocking") call mpl_scatterv(rbuf,kroot,sbuf,scounts,sdispl) call mpl_scatterv(rbufr,kroot,sbufr,scounts,sdispl) if (mpl_rank == kroot) then call mpl_scatterv(rbufd,kroot,sbufd,scounts,sdispl) else call mpl_scatterv(rbufd,kroot) endif case("nonblocking") ! trying to get a random failure do j=1,1 if (mpl_rank == kroot ) then call mpl_scatterv(rbuf,kroot,sbuf,scounts, sdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_scatterv(rbufr,kroot,sbufr,scounts, sdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_scatterv(rbufd,kroot,sbufd,scounts, sdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) else call mpl_scatterv(rbuf,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_scatterv(rbufr,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_scatterv(rbufd,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) endif call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_r) call mpl_wait(request_d) call mpl_wait(request_i) enddo end select ! test values if ( any(rbuf /= mpl_rank) ) then !write(0,*) 'send ', mpl_rank, scounts, sbuf !write(0,*) 'recv ', mpl_rank, rcounts, rdispl write(msg,*) trim(mode)//" int scatterv with displ test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr) /= mpl_rank) ) then write(msg,*) trim(mode)//" real scatterv with displ test failed on mpl_rank", mpl_rank, rbufr FAIL(msg) endif if ( any(nint(rbufd) /= mpl_rank) ) then write(msg,*) trim(mode)//" double scatterv with displ test failed on mpl_rank", mpl_rank, rbufd FAIL(msg) endif end subroutine do_scatterv end program test_mpl_scatterv fiat-ecmwf-2.0.0/tests/gstats/0000775000175000017500000000000015157200431016364 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/gstats/output/0000775000175000017500000000000015157200431017724 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/gstats/output/gstats_csv_basic.F900000664000175000017500000001442715157200431023535 0ustar alastairalastair! (C) Copyright 2026- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! PROGRAM TEST_GSTATS USE YOMGSTATS, ONLY : JPMAXSTAT USE EC_PARKIND, ONLY : JPRD USE EC_LUN, ONLY : NULOUT IMPLICIT NONE REAL(JPRD) :: AVEARRAY(0:JPMAXSTAT) CALL TEST_INIT() CALL GSTATS(0,0) CALL GSTATS(1,0) CALL WORK_SECTION_1() CALL GSTATS(1,1) CALL GSTATS(2,0) CALL WORK_SECTION_2() CALL GSTATS(2,1) CALL GSTATS(0,1) CALL GSTATS_PRINT(NULOUT,AVEARRAY, JPMAXSTAT) ! CHECK THAT THE CSV FILE EXISTS CALL CHECK_OUTPUT() CALL TEST_END() CONTAINS ! --------------------------------------------------------------------- SUBROUTINE WORK_SECTION_1 IMPLICIT NONE REAL(JPRD) :: X INTEGER :: I X = 0.0_JPRD DO I = 1, 5000000 X = X + SIN(REAL(I, JPRD)) END DO END SUBROUTINE WORK_SECTION_1 ! --------------------------------------------------------------------- SUBROUTINE WORK_SECTION_2 IMPLICIT NONE REAL(JPRD) :: X INTEGER :: I X = 1.0_JPRD DO I = 1, 4000000 X = X * 1.0000001_JPRD END DO END SUBROUTINE WORK_SECTION_2 ! --------------------------------------------------------------------- SUBROUTINE TEST_INIT USE MPL_MODULE, ONLY : MPL_RANK, MPL_NUMPROC, MPL_INIT USE EC_LUN, ONLY : NULOUT INTEGER :: KPROC, KMYPROC, JPROC INTEGER, ALLOCATABLE :: KPRCIDS(:) LOGICAL :: LDSTATS, LDSTATSCPU, LDSYNCSTATS LOGICAL :: LDDETAILED_STATS, LDBARRIER_STATS, LDBARRIER_STATS2 LOGICAL :: LDSTATS_OMP, LDSTATS_COMMS, LDSTATS_MEM LOGICAL :: LDSTATS_ALLOC, LDTRACE_STATS, LDXML_STATS, LDCSV_STATS INTEGER :: KSTATS_MEM, KTRACE_STATS, KPRNT_STATS LOGICAL :: LUSE_MPI #include "gstats_setup.intfb.h" ! INITIALIZE ENVIRONMENT LUSE_MPI = DETECT_MPIRUN() KPROC = 1 KMYPROC = 1 IF (LUSE_MPI) THEN CALL MPL_INIT(LDINFO=.TRUE.) KMYPROC = MPL_RANK KPROC = MPL_NUMPROC ENDIF IF (KMYPROC == 1) THEN WRITE(0,*) "LUSE_MPI: ", LUSE_MPI WRITE(0,*) "NPROC: ", KPROC ELSE ! All other ranks set EC_LUN's NULOUT to /dev/null OPEN(UNIT=NULOUT, FILE='/dev/null') ENDIF ALLOCATE(KPRCIDS(KPROC)) LDSTATS = .TRUE. LDSTATSCPU = .FALSE. LDSYNCSTATS = .FALSE. LDDETAILED_STATS = .TRUE. LDBARRIER_STATS = .FALSE. LDBARRIER_STATS2 = .FALSE. LDSTATS_OMP = .FALSE. LDSTATS_COMMS = .FALSE. LDSTATS_MEM = .FALSE. KSTATS_MEM = 0 LDSTATS_ALLOC = .FALSE. LDTRACE_STATS = .FALSE. KTRACE_STATS = 0 KPRNT_STATS = KPROC LDXML_STATS = .FALSE. LDCSV_STATS = .TRUE. DO JPROC = 1, KPROC KPRCIDS(JPROC) = JPROC ENDDO CALL GSTATS_SETUP( KPROC, KMYPROC, KPRCIDS, & LDSTATS, LDSTATSCPU, LDSYNCSTATS, LDDETAILED_STATS, & LDBARRIER_STATS, LDBARRIER_STATS2, & LDSTATS_OMP, LDSTATS_COMMS, LDSTATS_MEM, KSTATS_MEM, LDSTATS_ALLOC, & LDTRACE_STATS, KTRACE_STATS, KPRNT_STATS, LDXML_STATS, LDCSV_STATS ) CALL GSTATS_LABEL(0, " ", "TOTAL EXECUTION") CALL GSTATS_LABEL(1, "CAT 1", "WORK 1") ! Note that second argument will be truncated to 3 chars CALL GSTATS_LABEL(2, "CAT 1", "WORK 2") ! Note that second argument will be truncated to 3 chars CALL GSTATS_PSUT END SUBROUTINE TEST_INIT ! --------------------------------------------------------------------- SUBROUTINE TEST_END USE MPL_MODULE, ONLY : MPL_END, MPL_NUMPROC IF (MPL_NUMPROC > 0) THEN CALL MPL_END(LDMEMINFO=.FALSE.) ENDIF END SUBROUTINE TEST_END ! --------------------------------------------------------------------- SUBROUTINE CHECK_OUTPUT USE MPL_MODULE, ONLY : MPL_RANK, MPL_NUMPROC IMPLICIT NONE LOGICAL :: EXISTS CHARACTER(LEN=32) :: FNAME INTEGER :: U INTEGER :: MYPROC MYPROC = 1 IF (MPL_NUMPROC > 0) THEN MYPROC = MPL_RANK ENDIF WRITE(FNAME, '(A,I0,A)') 'gstats.', MYPROC, '.csv' INQUIRE(FILE=FNAME, EXIST=EXISTS) IF (.NOT. EXISTS) THEN PRINT *, "ERROR: GSTATS DID NOT CREATE FILE: ", TRIM(FNAME) STOP 1 ELSE OPEN(NEWUNIT=U, FILE=FNAME, STATUS='OLD') CLOSE(U, STATUS='DELETE') PRINT *, "OK: FILE GENERATED: ", TRIM(FNAME) END IF END SUBROUTINE CHECK_OUTPUT ! --------------------------------------------------------------------- function detect_mpirun() result(lmpi_required) logical :: lmpi_required integer :: ilen integer, parameter :: nvars = 4 character(len=32), dimension(nvars) :: cmpirun_detect character(len=4) :: clenv_value integer :: ivar lmpi_required = .false. call get_environment_variable(name='FIAT_USE_MPI', value=clenv_value, length=ilen) write(0,*) "FIAT_USE_MPI: ", clenv_value if (ilen > 0) then if (clenv_value == '1' .or. clenv_value == 'TRUE' .or. clenv_value == 'ON') then write(0,*) "FIAT_USE_MPI environment variable set to a true value, MPI will be used" lmpi_required = .true. else write(0,*) "FIAT_USE_MPI environment variable set to a false value, MPI will NOT be used" lmpi_required = .false. endif return endif ! Environment variables that are set when mpirun, srun, aprun, ... are used cmpirun_detect(1) = 'OMPI_COMM_WORLD_SIZE' ! openmpi cmpirun_detect(2) = 'ALPS_APP_PE' ! cray pe cmpirun_detect(3) = 'PMI_SIZE' ! intel cmpirun_detect(4) = 'SLURM_NTASKS' ! slurm do ivar = 1, nvars call get_environment_variable(name=trim(cmpirun_detect(ivar)), length=ilen) if (ilen > 0) then lmpi_required = .true. exit ! break endif enddo end function END PROGRAM TEST_GSTATS fiat-ecmwf-2.0.0/tests/gstats/output/CMakeLists.txt0000664000175000017500000000236115157200431022466 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. if( NOT DEFINED fiatlib ) set(fiatlib fiat) endif() # ---------------------------------------------------------------------------------------- # Tests: fiat_test_gstats_csv_output (only gstats print csv so far) ecbuild_add_executable( TARGET fiat_test_gstats_csv_output SOURCES gstats_csv_basic.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_gstats_csv_output_mpi0 COMMAND fiat_test_gstats_csv_output ENVIRONMENT "FIAT_USE_MPI=0" ) ecbuild_add_test( TARGET fiat_test_gstats_csv_output_mpi1 COMMAND fiat_test_gstats_csv_output MPI 1 CONDITION HAVE_MPI ) ecbuild_add_test( TARGET fiat_test_gstats_csv_output_mpi2 COMMAND fiat_test_gstats_csv_output MPI 2 CONDITION HAVE_MPI ) # ----------------------------------------------------------------------------------------fiat-ecmwf-2.0.0/tests/gstats/CMakeLists.txt0000664000175000017500000000062515157200431021127 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. add_subdirectory( output )fiat-ecmwf-2.0.0/tests/test_namelist.F900000664000175000017500000000623615157200431020221 0ustar alastairalastair! (C) Copyright 2021- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Testing of ec_args; expected to be launched with 3 arguments: ! arg1 arg2 arg3 ! #define FAIL(msg) call fail_impl(msg,__LINE__) program test_namelist use namelist_mod #ifdef NAGFOR use f90_unix_dir, only: unlink #endif implicit none character(len=*),parameter :: cfile = 'fort.4' logical,parameter :: lvalue_check = .true. integer,parameter :: ivalue_check = 12 real,parameter :: rvalue_check = 0.12 character(len=*),parameter :: cvalue_check = 'NONE' integer :: kulnam = 4 logical :: lvalue = .false. integer :: ivalue = 0 real :: rvalue = 0.0 character(len=80) :: cvalue = '' character(len=*),parameter :: cpresent = 'NAMBLOCK2' character(len=*),parameter :: cnonpresent = 'NAM_NONPRESENT' namelist/NAMBLOCK2/lvalue,ivalue,rvalue,cvalue namelist/NAM_NONPRESENT/lvalue,ivalue,rvalue,cvalue call write_namelist() open(kulnam, file=cfile) call test_posnamef_present() call test_posnamef_nonpresent() call test_posnam_present() call test_posnam_nonpresent() close(kulnam) ! checking it also works with a closed kulnam, ! guessing filename (fort.kulnam) and opening it call test_posnam_present() contains subroutine write_namelist() implicit none integer :: iunit = 4 logical :: lexist inquire(file=cfile, exist=lexist) if (lexist) then print*, "Removing", cfile call unlink(cfile) endif open(iunit, file=cfile, status='NEW') write(iunit,*) '&NAMBLOCK1' write(iunit,*) '/' write(iunit,*) '&NAMBLOCK2' write(iunit,*) ' LVALUE=.TRUE.,' write(iunit,*) ' RVALUE=0.12,' write(iunit,*) ' IVALUE=12,' write(iunit,*) ' CVALUE="NONE",' write(iunit,*) '/' write(iunit,*) '&NAMBLOCK3' write(iunit,*) '/' close(iunit) end subroutine write_namelist subroutine test_posnamef_present() implicit none if (posnamef(kulnam, cpresent, ldfatal=.false., ldverbose=.true.) == 0) read(kulnam, NAMBLOCK2) if (lvalue .neqv. lvalue_check) FAIL("LVALUE") if (ivalue /= ivalue_check) FAIL("IVALUE") if (rvalue /= rvalue_check) FAIL("RVALUE") if (trim(cvalue) /= trim(cvalue_check)) FAIL("CVALUE") end subroutine test_posnamef_present subroutine test_posnamef_nonpresent() implicit none if (posnamef(kulnam, cnonpresent, ldfatal=.false., ldverbose=.true.) == 0) then read(kulnam, NAM_NONPRESENT) else print*,'This should not be printed' endif end subroutine test_posnamef_nonpresent subroutine test_posnam_present() implicit none call posnam(kulnam, cpresent) read(kulnam, NAMBLOCK2) end subroutine test_posnam_present subroutine test_posnam_nonpresent() implicit none call posnam(kulnam, cnonpresent) ! should call abor1 end subroutine test_posnam_nonpresent subroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_namelist.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine end program fiat-ecmwf-2.0.0/tests/test_drhook_counters_gemm.F900000664000175000017500000000370615157200431022621 0ustar alastairalastairmodule test_drhook_counters_gemm_mod use yomhook, only : lhook,dr_hook,jphook implicit none contains subroutine gemm_combinations(n_init) implicit none integer(kind=8), intent(in), optional :: n_init integer(kind=8) :: n,i real(kind=jphook) :: zhook_handle n=1000 if (present(n_init)) then n = n_init endif #if defined(HAVE_BLAS) if (lhook) call dr_hook('GEMM_ALL',0,zhook_handle) do i=1,4 call dgemm_driver(n) call sgemm_driver(n) n=n*2 end do if (lhook) call dr_hook('GEMM_ALL',1,zhook_handle) #endif end subroutine gemm_combinations #if defined(HAVE_BLAS) subroutine dgemm_driver(nn) implicit none double precision, allocatable :: a(:,:),b(:,:),c(:,:) double precision :: alpha,beta integer :: m,k,n integer :: i,j integer*8 :: nn real(kind=jphook) :: zhook_handle character(len=25) :: tag write(tag,'(i20)')nn tag="_n="//adjustl(tag) m=nn n=nn k=nn alpha=1.0 beta=0.0 allocate(a(m,k), b(k,n), c(m,n)) a=1.0 b=2.0 c=3.0 if (lhook) call dr_hook('DGEMM'//TRIM(tag),0,zhook_handle) call dgemm('n','n',m,n,k,alpha,a,m,b,k,beta,c,m) if (lhook) call dr_hook('DGEMM'//TRIM(tag),1,zhook_handle) return end subroutine dgemm_driver subroutine sgemm_driver(nn) implicit none real*4, allocatable :: a(:,:),b(:,:),c(:,:) real*4 :: alpha,beta integer :: m,k,n integer :: i,j integer*8 :: nn real(kind=jphook) :: zhook_handle character(len=25) :: tag write(tag,'(i20)')nn tag="_n="//adjustl(tag) m=nn n=nn k=nn alpha=1.0 beta=0.0 allocate(a(m,k), b(k,n), c(m,n)) a=1.0 b=2.0 c=3.0 if (lhook) call dr_hook('SGEMM'//TRIM(tag),0,zhook_handle) call sgemm('n','n',m,n,k,alpha,a,m,b,k,beta,c,m) if (lhook) call dr_hook('SGEMM'//TRIM(tag),1,zhook_handle) return end subroutine sgemm_driver #endif end module fiat-ecmwf-2.0.0/tests/test_drhook_counters_stream.F900000664000175000017500000003223515157200431023166 0ustar alastairalastairMODULE test_drhook_counters_stream_mod !======================================================================= ! Program: STREAM ! Programmer: John D. McCalpin ! RCS Revision: $Id: stream.f,v 5.6 2005/10/04 00:20:48 mccalpin Exp mccalpin $ !----------------------------------------------------------------------- ! Copyright 1991-2003: John D. McCalpin !----------------------------------------------------------------------- ! License: ! 1. You are free to use this program and/or to redistribute ! this program. ! 2. You are free to modify this program for your own use, ! including commercial use, subject to the publication ! restrictions in item 3. ! 3. You are free to publish results obtained from running this ! program, or from works that you derive from this program, ! with the following limitations: ! 3a. In order to be referred to as "STREAM benchmark results", ! published results must be in conformance to the STREAM ! Run Rules, (briefly reviewed below) published at ! http://www.cs.virginia.edu/stream/ref.html ! and incorporated herein by reference. ! As the copyright holder, John McCalpin retains the ! right to determine conformity with the Run Rules. ! 3b. Results based on modified source code or on runs not in ! accordance with the STREAM Run Rules must be clearly ! labelled whenever they are published. Examples of ! proper labelling include: ! "tuned STREAM benchmark results" ! "based on a variant of the STREAM benchmark code" ! Other comparable, clear and reasonable labelling is ! acceptable. ! 3c. Submission of results to the STREAM benchmark web site ! is encouraged, but not required. ! 4. Use of this program or creation of derived works based on this ! program constitutes acceptance of these licensing restrictions. ! 5. Absolutely no warranty is expressed or implied. !----------------------------------------------------------------------- ! This program measures sustained memory transfer rates in MB/s for ! simple computational kernels coded in FORTRAN. ! ! The intent is to demonstrate the extent to which ordinary user ! code can exploit the main memory bandwidth of the system under ! test. use yomhook, only : lhook,dr_hook,jphook contains subroutine stream_combinations(n_init) implicit none integer(kind=8), intent(in), optional :: n_init integer(kind=8) :: n, ntimes, i real(kind=jphook) :: zhook_handle n=1024*1024 if (present(n_init)) then n = n_init endif ntimes=1024 if (lhook) call dr_hook('STREAM',0,zhook_handle) do i=1,3 write(6,'(" =============================== CALL STREAM(",I0,",",I0,")")') n, ntimes call stream(n,ntimes) n=n*8 ntimes=ntimes/8 end do if (lhook) call dr_hook('STREAM',1,zhook_handle) end subroutine stream_combinations SUBROUTINE stream(n,ntimes) !$ USE omp_lib INTEGER*8 n,offset,ndim INTEGER*8 ntimes PARAMETER (offset=0) ! .. ! .. Local Scalars .. DOUBLE PRECISION scalar,t INTEGER j,k,nbpw,quantum ! .. ! .. Local Arrays .. DOUBLE PRECISION maxtime(4),mintime(4),avgtime(4), & times(4,ntimes) INTEGER bytes(4) CHARACTER label(4)*11 ! .. ! .. External Functions .. DOUBLE PRECISION timef REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPHOOK) :: ZHOOK_1,ZHOOK_2,ZHOOK_3,ZHOOK_4 CHARACTER(len=29) :: tag ! INTEGER realsize EXTERNAL mysecond !,checktick !,realsize ! .. ! .. Intrinsic Functions .. ! INTRINSIC dble,max,min,nint,sqrt ! .. ! .. Arrays in Common .. DOUBLE PRECISION, allocatable :: a(:),b(:),c(:) !dir$ attributes align:64 :: A, B, C ! CHARACTER(len=40) :: suffix ! .. ! .. Common blocks .. ! COMMON a,b,c ! .. ! .. Data statements .. DATA avgtime/4*0.0D0/,mintime/4*1.0D+36/,maxtime/4*0.0D0/ DATA label/'Copy: ','Scale: ','Add: ','Triad: '/ DATA bytes/2,2,3,3/ ! .. ! WRITE(suffix,'(A,I30)')"_",n ! --- SETUP --- determine precision and check timing --- ndim=n+offset allocate(a(ndim),b(ndim),c(ndim)) nbpw = realsize() write(tag,'(I20)')n !$ if (omp_in_parallel()) then !$ tag="_par_n="//adjustl(tag) !$ else tag="_n="//adjustl(tag) !$ end if PRINT *,'----------------------------------------------' PRINT *,'STREAM Version $Revision: 5.6 $' PRINT *,'----------------------------------------------' WRITE (*,FMT=9010) 'Array size = ',n WRITE (*,FMT=9010) 'Offset = ',offset WRITE (*,FMT=9020) 'The total memory requirement is ', & 3*nbpw*n/ (1024*1024),' MB' WRITE (*,FMT=9030) 'You are running each test ',ntimes,' times' WRITE (*,FMT=9030) '--' WRITE (*,FMT=9030) 'The *best* time for each test is used' WRITE (*,FMT=9030) '*EXCLUDING* the first and last iterations' !$OMP PARALLEL !$OMP MASTER PRINT *,'----------------------------------------------' !$ PRINT *,'Number of Threads = ',OMP_GET_NUM_THREADS() !$OMP END MASTER !$OMP END PARALLEL PRINT *,'----------------------------------------------' !$OMP PARALLEL DO DO 10 j = 1,n a(j) = 2.0d0 b(j) = 0.5D0 c(j) = 0.0D0 10 END DO t = timef() !$OMP PARALLEL DO DO 20 j = 1,n a(j) = 0.5d0*a(j) 20 END DO t = timef() - t PRINT *,'----------------------------------------------------' quantum = checktick() WRITE (*,FMT=9000) & 'Your clock granularity/precision appears to be ',quantum, & ' microseconds' PRINT *,'----------------------------------------------------' ! --- MAIN LOOP --- repeat test cases NTIMES times --- scalar = 0.5d0*a(1) DO 70 k = 1,ntimes IF (LHOOK) CALL DR_HOOK('STREAM_COPY'//TRIM(tag),0,ZHOOK_1) t = timef() a(1) = a(1) + t !$OMP PARALLEL DO DO 30 j = 1,n c(j) = a(j) 30 END DO t = timef() - t IF (LHOOK) CALL DR_HOOK('STREAM_COPY'//TRIM(tag),1,ZHOOK_1) c(n) = c(n) + t times(1,k) = t IF (LHOOK) CALL DR_HOOK('STREAM_SCALE'//TRIM(tag),0,ZHOOK_2) t = timef() c(1) = c(1) + t !$OMP PARALLEL DO DO 40 j = 1,n b(j) = scalar*c(j) 40 END DO t = timef() - t IF (LHOOK) CALL DR_HOOK('STREAM_SCALE'//TRIM(tag),1,ZHOOK_2) b(n) = b(n) + t times(2,k) = t IF (LHOOK) CALL DR_HOOK('STREAM_ADD'//TRIM(tag),0,ZHOOK_3) t = timef() a(1) = a(1) + t !$OMP PARALLEL DO DO 50 j = 1,n c(j) = a(j) + b(j) 50 END DO t = timef() - t IF (LHOOK) CALL DR_HOOK('STREAM_ADD'//TRIM(tag),1,ZHOOK_3) c(n) = c(n) + t times(3,k) = t IF (LHOOK) CALL DR_HOOK('STREAM_TRIAD'//TRIM(tag),0,ZHOOK_4) t = timef() b(1) = b(1) + t !$OMP PARALLEL DO DO 60 j = 1,n a(j) = b(j) + scalar*c(j) 60 END DO t = timef() - t IF (LHOOK) CALL DR_HOOK('STREAM_TRIAD'//TRIM(tag),1,ZHOOK_4) a(n) = a(n) + t times(4,k) = t 70 END DO ! --- SUMMARY --- DO 90 k = 2,ntimes DO 80 j = 1,4 avgtime(j) = avgtime(j) + times(j,k) mintime(j) = min(mintime(j),times(j,k)) maxtime(j) = max(maxtime(j),times(j,k)) 80 END DO 90 END DO WRITE (*,FMT=9040) DO 100 j = 1,4 avgtime(j) = avgtime(j)/dble(ntimes-1) WRITE (*,FMT=9050) label(j),n*bytes(j)*nbpw/mintime(j)/1.0D6, & avgtime(j),mintime(j),maxtime(j) 100 END DO PRINT *,'----------------------------------------------------' CALL checksums (a,b,c,n,ntimes) PRINT *,'----------------------------------------------------' 9000 FORMAT (1x,a,i6,a) 9010 FORMAT (1x,a,i10) 9020 FORMAT (1x,a,i7,a) 9030 FORMAT (1x,a,i5,a,a) 9040 FORMAT ('Function',5x,'Rate (MB/s) Avg time Min time Max time' & ) 9050 FORMAT (a,4 (f12.4,2x)) END SUBROUTINE stream !------------------------------------- ! INTEGER FUNCTION dblesize() ! ! A semi-portable way to determine the precision of DOUBLE PRECISION ! in Fortran. ! Here used to guess how many bytes of storage a DOUBLE PRECISION ! number occupies. ! INTEGER FUNCTION realsize() ! IMPLICIT NONE ! .. Local Scalars .. DOUBLE PRECISION result,test INTEGER j,ndigits ! .. ! .. Local Arrays .. DOUBLE PRECISION ref(30) ! .. ! .. External Subroutines .. ! EXTERNAL confuse ! .. ! .. Intrinsic Functions .. INTRINSIC abs,acos,log10,sqrt ! .. ! Test #1 - compare single(1.0d0+delta) to 1.0d0 10 DO 20 j = 1,30 ref(j) = 1.0d0 + 10.0d0** (-j) 20 END DO DO 30 j = 1,30 test = ref(j) ndigits = j CALL confuse(test,result) IF (test.EQ.1.0D0) THEN GO TO 40 END IF 30 END DO GO TO 50 40 WRITE (*,FMT='(a)') & '----------------------------------------------' WRITE (*,FMT='(1x,a,i2,a)') 'Double precision appears to have ', & ndigits,' digits of accuracy' IF (ndigits.LE.8) THEN realsize = 4 ELSE realsize = 8 END IF WRITE (*,FMT='(1x,a,i1,a)') 'Assuming ',realsize, & ' bytes per DOUBLE PRECISION word' WRITE (*,FMT='(a)') & '----------------------------------------------' RETURN 50 PRINT *,'Hmmmm. I am unable to determine the size.' PRINT *,'Please enter the number of Bytes per DOUBLE PRECISION', & ' number : ' READ (*,FMT=*) realsize IF (realsize.NE.4 .AND. realsize.NE.8) THEN PRINT *,'Your answer ',realsize,' does not make sense.' PRINT *,'Try again.' PRINT *,'Please enter the number of Bytes per ', & 'DOUBLE PRECISION number : ' READ (*,FMT=*) realsize END IF PRINT *,'You have manually entered a size of ',realsize, & ' bytes per DOUBLE PRECISION number' WRITE (*,FMT='(a)') & '----------------------------------------------' END FUNCTION realsize SUBROUTINE confuse(q,r) ! IMPLICIT NONE ! .. Scalar Arguments .. DOUBLE PRECISION q,r ! .. ! .. Intrinsic Functions .. INTRINSIC cos ! .. r = cos(q) RETURN END SUBROUTINE confuse ! A semi-portable way to determine the clock granularity ! Adapted from a code by John Henning of Digital Equipment Corporation ! INTEGER FUNCTION checktick() ! IMPLICIT NONE ! .. Parameters .. INTEGER n PARAMETER (n=20) ! .. ! .. Local Scalars .. DOUBLE PRECISION t1,t2 INTEGER i,j,jmin ! .. ! .. Local Arrays .. DOUBLE PRECISION timesfound(n) ! .. ! .. External Functions .. DOUBLE PRECISION timef EXTERNAL timef ! .. ! .. Intrinsic Functions .. INTRINSIC max,min,nint ! .. i = 0 t1=-1 10 t2 = timef() IF (t2.EQ.t1) GO TO 10 t1 = t2 i = i + 1 timesfound(i) = t1 IF (i.LT.n) GO TO 10 jmin = 1000000 DO 20 i = 2,n j = nint((timesfound(i)-timesfound(i-1))*1d6) jmin = min(jmin,max(j,0)) 20 END DO IF (jmin.GT.0) THEN checktick = jmin ELSE PRINT *,'Your clock granularity appears to be less ', & 'than one microsecond' checktick = 1 END IF RETURN ! PRINT 14, timesfound(1)*1d6 ! DO 20 i=2,n ! PRINT 14, timesfound(i)*1d6, ! & nint((timesfound(i)-timesfound(i-1))*1d6) ! 14 FORMAT (1X, F18.4, 1X, i8) ! 20 END DO END FUNCTION checktick SUBROUTINE checksums(a,b,c,n,ntimes) ! IMPLICIT NONE ! .. ! .. Arguments .. DOUBLE PRECISION a(*),b(*),c(*) INTEGER*8 n,ntimes ! .. ! .. Local Scalars .. DOUBLE PRECISION aa,bb,cc,scalar,suma,sumb,sumc,epsilon INTEGER k ! .. ! Repeat the main loop, but with scalars only. ! This is done to check the sum & make sure all ! iterations have been executed correctly. aa = 2.0D0 bb = 0.5D0 cc = 0.0D0 aa = 0.5D0*aa scalar = 0.5d0*aa DO k = 1,ntimes cc = aa bb = scalar*cc cc = aa + bb aa = bb + scalar*cc END DO aa = aa*DBLE(n-2) bb = bb*DBLE(n-2) cc = cc*DBLE(n-2) ! Now sum up the arrays, excluding the first and last ! elements, which are modified using the timing results ! to confuse aggressive optimizers. suma = 0.0d0 sumb = 0.0d0 sumc = 0.0d0 !$OMP PARALLEL DO REDUCTION(+:suma,sumb,sumc) DO 110 j = 2,n-1 suma = suma + a(j) sumb = sumb + b(j) sumc = sumc + c(j) 110 END DO epsilon = 1.D-6 IF (ABS(suma-aa)/suma .GT. epsilon) THEN PRINT *,'Failed Validation on array a()' PRINT *,'Target Sum of a is = ',aa PRINT *,'Computed Sum of a is = ',suma ELSEIF (ABS(sumb-bb)/sumb .GT. epsilon) THEN PRINT *,'Failed Validation on array b()' PRINT *,'Target Sum of b is = ',bb PRINT *,'Computed Sum of b is = ',sumb ELSEIF (ABS(sumc-cc)/sumc .GT. epsilon) THEN PRINT *,'Failed Validation on array c()' PRINT *,'Target Sum of c is = ',cc PRINT *,'Computed Sum of c is = ',sumc ELSE PRINT *,'Solution Validates!' ENDIF END SUBROUTINE checksums function itoa(i) result(res) character(:),allocatable :: res integer,intent(in) :: i character(range(i)+2) :: tmp write(tmp,'(i0)') i res = trim(tmp) end function itoa END MODULE fiat-ecmwf-2.0.0/tests/test_drhook_no_output.c0000664000175000017500000000210415157200431021661 0ustar alastairalastair/* * (C) Copyright 2003- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include "drhook.h" const int OVERWRITE = 1; const int DONT_OVERWRITE = 0; void function_2 () { DRHOOK_START(); DRHOOK_END(); } void function_1 () { int i; DRHOOK_START(); for( i=0; i<2; ++i ) { function_2(); } DRHOOK_END(); } void setup_test(int argc, char* argv[]) { setenv("DR_HOOK", "1", OVERWRITE); setenv("DR_HOOK_SILENT","1", DONT_OVERWRITE); drhook_init(argc,argv); if( ! drhook_active() ) { drhook_abort(__FILE__,__LINE__,"drhook is supposed to be activated"); } } int main(int argc, char* argv[]) { setup_test(argc,argv); DRHOOK_START(); function_1(); DRHOOK_END(); } fiat-ecmwf-2.0.0/tests/drhook/0000775000175000017500000000000015157200431016345 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/drhook/drhook_ex.log20000664000175000017500000006074615157200431021131 0ustar alastairalastair if [[ $# -eq 1 ]] ; then export ARCH=$1 else export ARCH=${ARCH:=ibm_power4} fi if [[ "$ARCH" = ibm_power4 ]] ; then #-- IBM Power4 FC="xlf90_r -g -qsmp=omp -qextname -qsuffix=cpp=F90 -qfree=F90 -I." CC="xlc_r -g -qsmp=noauto -I." LIBS="-L. -ldrhook -lmpi_serial -L/usr/pmapi/lib -lpmapi" elif [[ "$ARCH" = rs6000 ]] ; then #-- IBM Power3 (at ECMWF) FC="xlf90_r -g -qsmp=omp -qextname -qsuffix=cpp=F90 -qfree=F90 -I." CC="xlc_r -g -qsmp=noauto -I." LIBS="-L. -ldrhook -lmpi_serial" elif [[ "$ARCH" = linux ]] ; then #-- Linux with Portland Group F90 (for IA32) FC="pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC" CC="gcc -g -m32 -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial -Wl,-export-dynamic" elif [[ "$ARCH" = linuxg95 ]] ; then #-- Linux with GNU g95 FC="g95 -mp -I. -g -fno-second-underscore" CC="gcc -g -m32 -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial" elif [[ "$ARCH" = ia64 ]] ; then #-- Linux with Intel F90 FC="ifort -openmp -cpp -I. -g -fpe0 -O1 -assume byterecl -assume cc_omp -traceback \ -assume cc_omp -assume underscore -lowercase -nomixed_str_len_arg -fPIC" CC="gcc -g -m64 -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial -Wl,-export-dynamic" elif [[ "$ARCH" = amd64 ]] ; then #-- Linux with Portland Group F90 -- for AMD64 FC="pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC -tp amd64" CC="gcc -g -m64 -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial -Wl,-export-dynamic" elif [[ "$ARCH" = @(*alpha) ]] ; then #-- ECMWF Dec Alpha (nowadays an outdated toy machine) FC="f90 -convert big_endian -O0 -assume byterecl" CC="cc -std -g -O0" LIBS="-L. -ldrhook -lmpi_serial" elif [[ "$ARCH" = i86pc ]] ; then #-- ECMWF Intel/Solaris FC="f90 -xfilebyteorder=big8:%all -I. -M." CC="gcc -g -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial -L/opt/sfw/lib/gcc-lib/i386-pc-solaris2.9/2.95.3 -lgcc" else echo "***Error: Unrecognized ARCH=$ARCH" echo " Please edit this file $0" exit 1 fi if [[ -f ./ODB_FCLIBS ]] ; then ODB_FCLIBS=$(cat ./ODB_FCLIBS) else ODB_FCLIBS="" fi #-- In case of shareable linkage ... LD_LIBRARY_PATH=${LD_LIBRARY_PATH:=.} if [[ "$LD_LIBRARY_PATH" != "." ]] ; then LD_LIBRARY_PATH=".:${LD_LIBRARY_PATH}" fi export LD_LIBRARY_PATH #-- Initialize (outside this script) the following to 0/1 to prevent/allow running GNU-debugger export GNUDEBUGGER=${GNUDEBUGGER:=0} set -xv #------------------------------------------------------------------------- # Example#0 : Show wordsizes in F90 & C of this arch #------------------------------------------------------------------------- ./sizeof.x + ./sizeof.x sizeof(void *) = 4 sizeof(char) = 1 sizeof(short int) = 2 sizeof(int) = 4 sizeof(long int) = 4 sizeof(long long int) = 8 sizeof(float) = 4 sizeof(double) = 8 ./kind.x + ./kind.x bit_size(i )= 32 4 (the default INTEGER) bit_size(i_JPIT)= 8 1 1 bit_size(i_JPIS)= 16 2 2 bit_size(i_JPIM)= 32 4 4 bit_size(i_JPIB)= 64 8 8 eps/huge(r )= 0.11920929000000000000E-06 0.34028235000000000000E+39 (the default REAL) eps/huge(r_JPRT)= 0.11920929000000000000E-06 0.34028235000000000000E+39 4 eps/huge(r_JPRS)= 0.11920929000000000000E-06 0.34028235000000000000E+39 4 eps/huge(r_JPRM)= 0.11920929000000000000E-06 0.34028235000000000000E+39 4 eps/huge(r_JPRB)= 0.22204460492503131000E-15 0.17976931348623167000+309 8 eps/huge(d )= 0.22204460492503131000E-15 0.17976931348623167000+309 (the default DOUBLE PRECISION) #------------------------------------------------------------------------- # Example#1 : Generate Dr.Hook, run and fail in divide by zero #------------------------------------------------------------------------- ./insert_drhook drhook_ex1.F90 + ./insert_drhook drhook_ex1.F90 insert_hook: drhook_ex1.F90 => _drhook_ex1.F90 $FC -I. _drhook_ex1.F90 -o drhook_ex1.x $LIBS + pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC -I. _drhook_ex1.F90 -o drhook_ex1.x -L. -ldrhook -lmpi_serial -Wl,-export-dynamic env DR_HOOK=1 ./drhook_ex1.x || : + env DR_HOOK=1 ./drhook_ex1.x MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 signal_drhook(SIGABRT=6): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGBUS=7): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGSEGV=11): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGILL=4): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGSTKFLT=16): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGFPE=8): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGTRAP=5): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGINT=2): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGQUIT=3): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGTERM=15): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGXCPU=24): New handler installed at 0x805749b; old preserved at 0x0 signal_drhook(SIGSYS=31): New handler installed at 0x805749b; old preserved at 0x0 [myproc#1,tid#1,pid#32361,signal#8(SIGFPE)]: Received signal :: 7MB (heap), 7MB (rss), 0MB (stack), 0 (paging), nsigs 1, time 0.01 Activating SIGALRM=14 and calling alarm(10), time = 0.01 JSETSIG: sl->active = 0 signal_drhook(SIGALRM=14): New handler installed at 0x805749b; old preserved at 0x0 tid#1 starting drhook traceback, time = 0.01 [myproc#1,tid#1,pid#32361]: DRHOOK_EX1 [myproc#1,tid#1,pid#32361]: SUB1 [myproc#1,tid#1,pid#32361]: SUB2 tid#1 starting sigdump traceback, time = 0.01 [gdb__sigdump] : Received signal#8(SIGFPE), pid=32361 [gdb__sigdump] : Backtrace of program './drhook_ex1.x' : /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/drhook.c:832 : drhook_ex1.x(strftime+0x1d07) [0x805705f] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/_drhook_ex1.F90:35 : drhook_ex1.x(sub2_+0x4a) [0x8055c4a] : libpthread.so.0 [0x5556ecc7] : libc.so.6 [0x555debf0] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/_drhook_ex1.F90:24 : drhook_ex1.x(sub1_+0x63) [0x8055bc3] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/_drhook_ex1.F90:10 : drhook_ex1.x(MAIN_+0xa3) [0x8055b03] : drhook_ex1.x(main+0x69) [0x8055a29] : libc.so.6(__libc_start_main+0xce) [0x555cad3e] ../sysdeps/i386/elf/start.S:105 : drhook_ex1.x(strcpy+0x39) [0x8055911] [gdb__sigdump] : End of backtrace Done tracebacks, calling exit with sig=8, time = 0.02 ABORT! 1 Dr.Hook calls ABOR1 ... ABOR1 CALLED Dr.Hook calls ABOR1 ... [myproc#1,tid#1,pid#32361]: DRHOOK_EX1 [myproc#1,tid#1,pid#32361]: SUB1 [myproc#1,tid#1,pid#32361]: SUB2 SDL_TRACEBACK: No traceback implemented. [myproc#1,tid#1,pid#32361,signal#6(SIGABRT)]: Received signal :: 7MB (heap), 7MB (rss), 0MB (stack), 0 (paging), nsigs 2, time 0.02 Killed + : #------------------------------------------------------------------------- # Example#2 : With the previous case fixed experience with watch point #------------------------------------------------------------------------- ./insert_drhook drhook_ex2.F90 + ./insert_drhook drhook_ex2.F90 insert_hook: drhook_ex2.F90 => _drhook_ex2.F90 $FC -I. _drhook_ex2.F90 -o drhook_ex2.x $LIBS + pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC -I. _drhook_ex2.F90 -o drhook_ex2.x -L. -ldrhook -lmpi_serial -Wl,-export-dynamic env DR_HOOK=1 ./drhook_ex2.x || : + env DR_HOOK=1 ./drhook_ex2.x MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 signal_drhook(SIGABRT=6): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGBUS=7): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGSEGV=11): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGILL=4): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGSTKFLT=16): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGFPE=8): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGTRAP=5): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGINT=2): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGQUIT=3): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGTERM=15): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGXCPU=24): New handler installed at 0x805899b; old preserved at 0x0 signal_drhook(SIGSYS=31): New handler installed at 0x805899b; old preserved at 0x0 ***Warning: Watch point 'MAIN: array A(N)' was created for address 0x80b30b0 (800 bytes, on myproc#1, tid#1) : crc32=3160622197 ***Error: Watch point 'MAIN: array A(N)' at address 0x80b30b0 on myproc#1 has changed (detected in tid#1 when leaving routine SUB2) : new crc32=3567971738 ABOR1FL HAS BEEN CALLED AT drhook.c:001965 ABORT! 1 *** Fatal error; aborting (SIGABRT) ... ABOR1 CALLED *** Fatal error; aborting (SIGABRT) ... [myproc#1,tid#1,pid#32382]: DRHOOK_EX2 [myproc#1,tid#1,pid#32382]: SUB1 [myproc#1,tid#1,pid#32382]: SUB2 SDL_TRACEBACK: No traceback implemented. [myproc#1,tid#1,pid#32382,signal#6(SIGABRT)]: Received signal :: 7MB (heap), 7MB (rss), 0MB (stack), 0 (paging), nsigs 1, time 0.01 Activating SIGALRM=14 and calling alarm(10), time = 0.01 JSETSIG: sl->active = 0 signal_drhook(SIGALRM=14): New handler installed at 0x805899b; old preserved at 0x0 tid#1 starting drhook traceback, time = 0.01 [myproc#1,tid#1,pid#32382]: DRHOOK_EX2 [myproc#1,tid#1,pid#32382]: SUB1 [myproc#1,tid#1,pid#32382]: SUB2 tid#1 starting sigdump traceback, time = 0.01 [gdb__sigdump] : Received signal#6(SIGABRT), pid=32382 [gdb__sigdump] : Backtrace of program './drhook_ex2.x' : /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/drhook.c:832 : drhook_ex2.x [0x805855f] : libc.so.6(kill+0x11) [0x555decc1] : libpthread.so.0 [0x5556ecc7] : libc.so.6 [0x555debf0] : libpthread.so.0(raise+0x2b) [0x5556b38b] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/endian.c:68 : drhook_ex2.x(ec_raise_+0x1f) [0x80630e7] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/module/sdl_module.F90:71 : drhook_ex2.x(sdl_module_sdl_srlabort_+0x25) [0x80632a5] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/abor1.F90:39 : drhook_ex2.x(abor1_+0x4ec) [0x806203c] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/abor1.F90:53 : drhook_ex2.x(abor1fl_+0x143) [0x8062193] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/drhook.c:1965 : drhook_ex2.x [0x805bce1] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/drhook.c:2210 : drhook_ex2.x(c_drhook_end_+0xc8) [0x805c571] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/support/dr_hook_util.F90:36 : drhook_ex2.x(dr_hook_util_+0x1da) [0x80577ca] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/ifsaux/module/yomhook.F90:44 : drhook_ex2.x(yomhook_dr_hook_default_+0x3e) [0x805610e] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/_drhook_ex2.F90:39 : drhook_ex2.x(sub2_+0x74) [0x80560a4] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/_drhook_ex2.F90:27 : drhook_ex2.x(sub1_+0x63) [0x8055ff3] /var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116/_drhook_ex2.F90:11 : drhook_ex2.x(MAIN_+0x138) [0x8055f38] : drhook_ex2.x(main+0x69) [0x8055dc9] : libc.so.6(__libc_start_main+0xce) [0x555cad3e] ../sysdeps/i386/elf/start.S:105 : drhook_ex2.x(strcpy+0x31) [0x8055cb1] [gdb__sigdump] : End of backtrace Done tracebacks, calling exit with sig=6, time = 0.02 + : #------------------------------------------------------------------------- # Example#3 : Experience with different profilings. Also silence Dr.Hook! #------------------------------------------------------------------------- ./insert_drhook drhook_ex3.F90 + ./insert_drhook drhook_ex3.F90 insert_hook: drhook_ex3.F90 => _drhook_ex3.F90 $FC -I. _drhook_ex3.F90 -o drhook_ex3.x $LIBS + pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC -I. _drhook_ex3.F90 -o drhook_ex3.x -L. -ldrhook -lmpi_serial -Wl,-export-dynamic export DR_HOOK=1 + export DR_HOOK=1 export DR_HOOK_SILENT=1 + export DR_HOOK_SILENT=1 export DR_HOOK_SHOW_PROCESS_OPTIONS=0 + export DR_HOOK_SHOW_PROCESS_OPTIONS=0 #-- Wall clock profile env DR_HOOK_OPT=wallprof ./drhook_ex3.x + env DR_HOOK_OPT=wallprof ./drhook_ex3.x MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 Writing profiling information of proc#1 into file 'drhook.prof.1' Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144441 Instrumentation overhead: 58.33% Wall-time is 0.00 sec on proc#1 (1 procs, 1 threads) Thread#1: 0.00 sec (100.00%) mv drhook.prof.1 drhook.prof.1.wallprof + mv drhook.prof.1 drhook.prof.1.wallprof cat drhook.prof.1.wallprof + cat drhook.prof.1.wallprof Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144441 Instrumentation overhead: 58.33% Memory usage : 7 MBytes (heap), 7 MBytes (rss), 0 MBytes (stack), 0 (paging) Wall-time is 0.00 sec on proc#1 (1 procs, 1 threads) Thread#1: 0.00 sec (100.00%) # % Time Cumul Self Total # of calls Self Total Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) ms/call ms/call 1 51.25 0.001 0.001 0.002 2500 0.00 0.00 SUB2@1 2 46.59 0.003 0.001 0.004 100 0.01 0.04 SUB1@1 3 2.16 0.003 0.000 0.004 1 0.06 3.73 DRHOOK_EX3@1 #-- CPU-time profile env DR_HOOK_OPT=cpuprof ./drhook_ex3.x + env DR_HOOK_OPT=cpuprof ./drhook_ex3.x MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 Writing profiling information of proc#1 into file 'drhook.prof.1' Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144441 Instrumentation overhead: 0.00% Total CPU-time is 0.01 sec on proc#1 (1 procs, 1 threads) Thread#1: 0.01 sec (100.00%) mv drhook.prof.1 drhook.prof.1.cpuprof + mv drhook.prof.1 drhook.prof.1.cpuprof cat drhook.prof.1.cpuprof + cat drhook.prof.1.cpuprof Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144441 Instrumentation overhead: 0.00% Memory usage : 7 MBytes (heap), 7 MBytes (rss), 0 MBytes (stack), 0 (paging) Total CPU-time is 0.01 sec on proc#1 (1 procs, 1 threads) Thread#1: 0.01 sec (100.00%) # % Time Cumul Self Total # of calls Self Total Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) ms/call ms/call 1 100.00 0.010 0.010 0.010 100 0.10 0.10 SUB1@1 2 0.00 0.010 0.000 0.010 1 0.00 10.00 DRHOOK_EX3@1 3 -0.00 0.010 -0.000 -0.000 2500 -0.00 -0.00 SUB2@1 #-- Mflop-counter profile env DR_HOOK_OPT=hpmprof ./drhook_ex3.x + env DR_HOOK_OPT=hpmprof ./drhook_ex3.x MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 Writing profiling information of proc#1 into file 'drhook.prof.1' Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144441 Instrumentation overhead: 59.67% Wall-time is 0.00 sec on proc#1, 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) (1 procs, 1 threads) Thread#1: 0.00 sec (100.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) mv drhook.prof.1 drhook.prof.1.hpmprof + mv drhook.prof.1 drhook.prof.1.hpmprof cat drhook.prof.1.hpmprof + cat drhook.prof.1.hpmprof Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144441 Instrumentation overhead: 59.67% Memory usage : 7 MBytes (heap), 7 MBytes (rss), 0 MBytes (stack), 0 (paging) Wall-time is 0.00 sec on proc#1, 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) (1 procs, 1 threads) Thread#1: 0.00 sec (100.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) # % Time Cumul Self Total # of calls MIPS MFlops Div-% Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) 1 51.40 0.001 0.001 0.002 2500 0 0 0.0 SUB2@1 2 46.50 0.003 0.001 0.004 100 0 0 0.0 SUB1@1 3 2.10 0.003 0.000 0.004 1 0 0 0.0 DRHOOK_EX3@1 #-- Memory profile (only) env DR_HOOK_OPT=memprof ./drhook_ex3.x + env DR_HOOK_OPT=memprof ./drhook_ex3.x MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 Writing memory-profiling information of proc#1 into file 'drhook.prof.1-mem' Memory-profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144443 mv drhook.prof.1-mem drhook.prof.1.memprof + mv drhook.prof.1-mem drhook.prof.1.memprof cat drhook.prof.1.memprof + cat drhook.prof.1.memprof Memory-profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20060427 144441 Instrumentation ended : 20060427 144443 Memory usage : 0 MBytes (max.seen), 0 MBytes (leaked), 7 MBytes (heap), 7 MBytes (max.rss), 0 MBytes (max.stack), 0 (paging) # Memory-% Self-alloc + Children Self-Leaked Heap Max.Stack Paging #Calls #Allocs #Frees Routine@ (self) (bytes) (bytes) (bytes) (bytes) (bytes) (delta) 1 0.00 0 0 0 7958528 0 0 1 0 0 DRHOOK_EX3@1 2 0.00 0 0 0 7958528 0 0 100 0 0 SUB1@1 3 0.00 0 0 0 7958528 0 0 2500 0 0 SUB2@1 unset DR_HOOK + unset DR_HOOK unset DR_HOOK_SILENT + unset DR_HOOK_SILENT unset DR_HOOK_SHOW_PROCESS_OPTIONS + unset DR_HOOK_SHOW_PROCESS_OPTIONS #------------------------------------------------------------------------- # Example#4 : Check whether your Dr.Hook works with C-main program #------------------------------------------------------------------------- rc=0 + rc=0 $CC -c drhook_ex4.c || { set +xv echo "***Error: Your Dr.Hook C-main program test did not compile" rc=1 } + gcc -g -m32 -ansi -Werror -c drhook_ex4.c if [[ $rc -eq 0 ]] ; then set +xv $CC drhook_ex4.o -o ./drhook_ex4.x $LIBS $ODB_FCLIBS || { echo "***Error: Your Dr.Hook C-main program test did not link" rc=2 } fi + set +xv MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 signal_drhook(SIGABRT=6): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGBUS=7): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGSEGV=11): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGILL=4): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGSTKFLT=16): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGFPE=8): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGTRAP=5): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGINT=2): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGQUIT=3): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGTERM=15): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGXCPU=24): New handler installed at 0x805808b; old preserved at 0x0 signal_drhook(SIGSYS=31): New handler installed at 0x805808b; old preserved at 0x0 ./drhook_ex4.x: no. of C-args = 5 and F90-args (numargs) = 4 (cmpl_iargc_() = 4) argv[0] = './drhook_ex4.x' (./drhook_ex4.x) : getarg(0, farg) --> farg = './drhook_ex4.x' argv[1] = 'SIGFPE' (SIGFPE) : getarg(1, farg) --> farg = 'SIGFPE' argv[2] = 'ARG TEST' (ARG TEST) : getarg(2, farg) --> farg = 'ARG TEST' argv[3] = 'test arg' (test arg) : getarg(3, farg) --> farg = 'test arg' argv[4] = '/var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116' (/var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116) : getarg(4, farg) --> farg = '/var/tmp/tmpdir/mps/ia32/drhook_CY30R2.116' MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED MPL_INIT : MAILBOX SIZE= 1000000 MPL_BUFFER_METHOD: 2 0 ./drhook_ex4.x: no. of C-args = 1 and F90-args (numargs) = 0 (cmpl_iargc_() = 0) argv[0] = './drhook_ex4.x' (./drhook_ex4.x) : getarg(0, farg) --> farg = './drhook_ex4.x' Writing profiling information of proc#1 into file 'cdrhook.prof.1' Profiling information for program='./drhook_ex4.x', proc#1: No. of instrumented routines called : 8 Instrumentation started : 20060427 144443 Instrumentation ended : 20060427 144443 Instrumentation overhead: 53.87% Wall-time is 0.44 sec on proc#1 (1 procs, 1 threads) Thread#1: 0.44 sec (100.00%) Profiling information for program='./drhook_ex4.x', proc#1: No. of instrumented routines called : 8 Instrumentation started : 20060427 144443 Instrumentation ended : 20060427 144443 Instrumentation overhead: 53.87% Memory usage : 7 MBytes (heap), 7 MBytes (rss), 0 MBytes (stack), 0 (paging) Wall-time is 0.44 sec on proc#1 (1 procs, 1 threads) Thread#1: 0.44 sec (100.00%) # % Time Cumul Self Total # of calls Self Total Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) ms/call ms/call 1 32.25 0.143 0.143 0.598 1000 0.14 0.60 sub@1:drhook_ex4.c 2 31.26 0.282 0.139 0.216 200000 0.00 0.00 mysin@1:drhook_ex4.c 3 23.21 0.385 0.103 0.250 100000 0.00 0.00 mycos@1:drhook_ex4.c 4 13.15 0.443 0.058 0.097 100000 0.00 0.00 mysqrt@1:drhook_ex4.c 5 0.11 0.443 0.000 0.599 1 0.47 598.69 LOOP_BLOCK@1:drhook_ex4.c 6 0.01 0.443 0.000 0.000 1 0.05 0.05 ARGLIST_TEST@1:drhook_ex4.c 7 0.00 0.443 0.000 0.599 1 0.01 598.75 real_main@1:drhook_ex4.c 8 0.00 0.443 0.000 0.000 1 0.00 0.01 CDRHOOKINIT@1 fiat-ecmwf-2.0.0/tests/drhook/drhook_ex.ksh0000664000175000017500000002237715157200431021051 0ustar alastairalastair#!/bin/ksh trap 'set +x; echo "Received signal, aborting ..."; exit 1' 1 2 3 15 # # Run the 3 test examples provided in the Dr.Hook distribution # # These examples have been tested on ibm_power4 platform # where memory profiling and Mflop-counters are definitely available. # # Change the FC and LIBS first if you want to run it on your platform. # # Usage : drhook_ex.ksh [$ARCH] # # # Please note, that these example rely on serial MPI-lib # i.e. run only using one MPI-task # # In order to run with multiple processors, refer to your local # MPI documentation on how to include MPI-lib proper and how to run MPI- # applications on your platform. Also, do not forget to remove references # to lib mpi_serial ! # set -veu if [[ $# -eq 1 ]] ; then export ARCH=$1 else export ARCH=${ARCH:=ibm_power4} fi has_mpi=0 NPES=1 ECYOD="" if [[ "$ARCH" = ibm_power* ]] ; then #-- IBM Power4 FC="xlf90_r -g -qsmp=omp -qextname -qsuffix=cpp=F90 -qfree=F90 -I." CC="xlc_r -g -qsmp=noauto -I." #-- The following assumes that drhook.c has been compiled with -DHPM #-- Requires odbdummy because of ec_bind() LIBS="-L. -ldrhook -lmpi_serial -L/usr/pmapi/lib -lpmapi -lessl -lodbdummy" #-- If not compiled with -DHPM, then supply pm_* dummies # LIBS="-L. -ldrhook -lmpi_serial -lodbdummy -lessl" # Note: -lessl i.e. ESSL-library is needed due to jsort.F elif [[ "$ARCH" = rs6000 ]] ; then #-- IBM Power3 (at ECMWF) FC="xlf90_r -g -qsmp=omp -qextname -qsuffix=cpp=F90 -qfree=F90 -I." CC="xlc_r -g -qsmp=noauto -I." LIBS="-L. -ldrhook -lmpi_serial -lessl" elif [[ "$ARCH" = linux ]] ; then #-- Linux with Portland Group F90 (for IA32) FC="pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC" CC="gcc -g -m32 -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial -Wl,-export-dynamic" elif [[ "$ARCH" = @(linuxg95|cygwin) ]] ; then #-- Linux with GNU g95 FC="g95 -I. -g -fno-second-underscore" CC="gcc -g -m32 -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial" elif [[ "$ARCH" = ia64 ]] ; then #-- Linux with Intel F90 FC="ifort -openmp -cpp -I. -g -fpe0 -O1 -assume byterecl -assume cc_omp -traceback \ -assume cc_omp -assume underscore -lowercase -nomixed_str_len_arg -fPIC" CC="gcc -g -ansi -Werror" LIBS="-L. -ldrhook -lmpi_serial -Wl,-export-dynamic" elif [[ "$ARCH" = amd64 ]] ; then MPICH_ROOT=${MPICH_ROOT:=/not/available} if [[ -d $MPICH_ROOT && -x $MPICH_ROOT/bin/mpirun ]] ; then #-- Linux with Portland Group F90 -- for AMD64 with MPICH MPFC="$MPICH_ROOT/bin/mpif90 -f90=pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC -tp amd64" MPLIBS="-L. -ldrhook -L$MPICH_ROOT/lib -lmpichf90 -lmpich -ldl -Wl,-export-dynamic" NPES=2 mpirun="./mpirun.linux -np $NPES" has_mpi=1 fi #-- Linux with Portland Group F90 -- for AMD64 FC="pgf90 -mp -I. -g -Ktrap=fp -O1 -fPIC -tp amd64" LIBS="-L. -ldrhook -lmpi_serial -Wl,-export-dynamic" CC="gcc -g -m64 -ansi -Werror" elif [[ "$ARCH" = @(*alpha) ]] ; then #-- ECMWF Dec Alpha (nowadays an outdated toy machine) FC="f90 -convert big_endian -O0 -assume byterecl" CC="cc -std -g -O0" LIBS="-L. -ldrhook -lmpi_serial" elif [[ "$ARCH" = i86pc ]] ; then #-- ECMWF Intel/Solaris FC="f90 -xfilebyteorder=big8:%all -I. -M." CC=${CC:="gcc -g -ansi -Werror"} I86PC_GCC=${I86PC_GCC:="-L/opt/sfw/lib/gcc-lib/i386-pc-solaris2.9/2.95.3 -lgcc"} #suse 10.0: I86PC_GCC=${I86PC_GCC:="-L/usr/lib/gcc/i586-suse-linux/4.0.2 -lgcc"} LIBS="-L. -ldrhook -lmpi_serial $I86PC_GCC" export DBXDEBUGGER=${DBXDEBUGGER:=1} elif [[ "$ARCH" = "necsx" ]] ; then FC="./run_fe sxf90 -DNECSX -V -USX -Cvopt -Wf,-pvctl fullmsg vwork=stack,-L fmtlist transform" CC="./run_fe sxcc -DNECSX" LIBS="-L. -ldrhook -lmpi_serial -lgen -lcpp -lpthread" export DBXDEBUGGER=${DBXDEBUGGER:=1} elif [[ "$ARCH" = @(cray_xt*) ]] ; then FC="ftn -g" CC="cc -g" LIBS="-L. -ldrhook -ldl -Wl,-export-dynamic" #-- yod stuff MPFC="$FC" MPLIBS="$LIBS" NPES=2 mpirun="yod -sz $NPES" has_mpi=1 ECYOD="yod -sz 1 -SN" else echo "***Error: Unrecognized ARCH=$ARCH" echo " Please edit this file $0" exit 1 fi if [[ -f ./ODB_FCLIBS ]] ; then ODB_FCLIBS=$(cat ./ODB_FCLIBS) else ODB_FCLIBS="" fi #-- In case of shareable linkage ... LD_LIBRARY_PATH=${LD_LIBRARY_PATH:=.} if [[ "$LD_LIBRARY_PATH" != "." ]] ; then LD_LIBRARY_PATH=".:${LD_LIBRARY_PATH}" fi export LD_LIBRARY_PATH #-- Initialize (outside this script) the following to 0/1 to prevent/allow running GNU-debugger # export GNUDEBUGGER=${GNUDEBUGGER:=0} #-- Initialize (outside this script) the following to 0/1 to prevent/allow running DBX-debugger # export DBXDEBUGGER=${DBXDEBUGGER:=0} set -xv #------------------------------------------------------------------------- # Example#0 : Show wordsizes in F90 & C of this arch (these are MPI/serial) #------------------------------------------------------------------------- $ECYOD ./sizeof.x || : $ECYOD ./kind.x || : #------------------------------------------------------------------------- # Example#1 : Generate Dr.Hook, run and fail in divide by zero #------------------------------------------------------------------------- ./insert_drhook drhook_ex1.F90 $FC -I. _drhook_ex1.F90 -o drhook_ex1.x $LIBS env DR_HOOK=1 $ECYOD ./drhook_ex1.x || : #------------------------------------------------------------------------- # Example#2 : With the previous case fixed experience with watch point # Testing also mpl_arg_mod #------------------------------------------------------------------------- ./insert_drhook drhook_ex2.F90 $FC -I. _drhook_ex2.F90 -o drhook_ex2.x $LIBS env DR_HOOK=1 $ECYOD ./drhook_ex2.x 1000 || : #------------------------------------------------------------------------- # Example#3 : Experience with different profilings. Also silence Dr.Hook! #------------------------------------------------------------------------- ./insert_drhook drhook_ex3.F90 $FC -I. _drhook_ex3.F90 -o drhook_ex3.x $LIBS export DR_HOOK=1 export DR_HOOK_SILENT=1 export DR_HOOK_SHOW_PROCESS_OPTIONS=0 #-- Wall clock profile env DR_HOOK_OPT=wallprof $ECYOD ./drhook_ex3.x || : mv drhook.prof.1 drhook.prof.1.wallprof cat drhook.prof.1.wallprof #-- CPU-time profile env DR_HOOK_OPT=cpuprof $ECYOD ./drhook_ex3.x || : mv drhook.prof.1 drhook.prof.1.cpuprof cat drhook.prof.1.cpuprof #-- Mflop-counter profile env DR_HOOK_OPT=hpmprof $ECYOD ./drhook_ex3.x || : mv drhook.prof.1 drhook.prof.1.hpmprof cat drhook.prof.1.hpmprof #-- Wall clock & memory usage with timeline env DR_HOOK_OPT=wall,mem DR_HOOK_TIMELINE=-1 $ECYOD ./drhook_ex3.x > drhook.timeline 2>&1 || : ls -l drhook.timeline #-- Memory profile (only) env DR_HOOK_OPT=memprof $ECYOD ./drhook_ex3.x || : mv drhook.prof.1-mem drhook.prof.1.memprof cat drhook.prof.1.memprof unset DR_HOOK unset DR_HOOK_SILENT unset DR_HOOK_SHOW_PROCESS_OPTIONS #------------------------------------------------------------------------- # Example#4 : Check whether your Dr.Hook works with C-main program #------------------------------------------------------------------------- rc4=0 $CC -c drhook_ex4.c || { set +xv echo "***Error: Your Dr.Hook C-main program test did not compile" rc4=1 } if [[ $rc4 -eq 0 ]] ; then $CC drhook_ex4.o -o ./drhook_ex4.x $LIBS $ODB_FCLIBS || { set +xv echo "***Error: Your Dr.Hook C-main program test did not link" rc4=2 } fi if [[ $rc4 -eq 0 ]] ; then #-- Test 4a) : Trigger SIGFPE and fail env DR_HOOK=1 $ECYOD ./drhook_ex4.x SIGFPE "ARG TEST" 'test arg' `pwd` || : fi if [[ $rc4 -eq 0 ]] ; then #-- Test 4b) : Do not fail and produce wall clock profile export DR_HOOK_SILENT=1 export DR_HOOK_SHOW_PROCESS_OPTIONS=0 export DR_HOOK_PROFILE=cdrhook.prof.%d env DR_HOOK=1 DR_HOOK_OPT=wallprof $ECYOD ./drhook_ex4.x || : cat cdrhook.prof.1 unset DR_HOOK_PROFILE unset DR_HOOK_SILENT unset DR_HOOK_SHOW_PROCESS_OPTIONS fi set -xv #------------------------------------------------------------------------- # Example#5 : Check MPI implementation, if applicable #------------------------------------------------------------------------- rc5=0 export DR_HOOK=1 export DR_HOOK_SILENT=1 export DR_HOOK_SHOW_PROCESS_OPTIONS=0 if [[ $has_mpi -eq 1 ]] ; then # "*** Testing parallel MPI-implementation ***" ./insert_drhook drhook_ex5.F90 $MPFC -I. _drhook_ex5.F90 -o drhook_ex5.x $MPLIBS || rc5=$? if [[ $rc5 -eq 0 ]] ; then #-- Wall clock profile env DR_HOOK_OPT=wallprof $mpirun ./drhook_ex5.x one two three || rc5=$? if [[ ! -f drhook.prof.1 ]] ; then #-- Something went wrong ... reverting to serial version rc5=1 has_mpi=0 fi if [[ $rc5 -eq 0 ]] ; then typeset np=0 while [[ $np -lt $NPES ]] do ((np+=1)) mv drhook.prof.$np drhook.prof.$np.wallprof cat drhook.prof.$np.wallprof done fi fi fi if [[ $has_mpi -eq 0 ]] ; then rc5=0 # "*** Testing MPI-implementation with a dummy MPI-serial version ***" ./insert_drhook drhook_ex5.F90 $FC -I. _drhook_ex5.F90 -o drhook_ex5.x $LIBS || rc5=$? if [[ $rc5 -eq 0 ]] ; then #-- Wall clock profile env DR_HOOK_OPT=wallprof $ECYOD ./drhook_ex5.x one two three || rc5=$? if [[ $rc5 -eq 0 ]] ; then mv drhook.prof.1 drhook.prof.1.wallprof cat drhook.prof.1.wallprof fi fi fi unset DR_HOOK_PROFILE unset DR_HOOK_SILENT unset DR_HOOK_SHOW_PROCESS_OPTIONS #------------------------------------------------------------------------- ((rc=rc4+rc5)) exit $rc fiat-ecmwf-2.0.0/tests/drhook/drhook_core/0000775000175000017500000000000015157200431020643 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/drhook/drhook_core/drhook_fn_process_options/0000775000175000017500000000000015157200431026125 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/drhook/drhook_core/drhook_fn_process_options/dummy.F900000664000175000017500000000113215157200431027535 0ustar alastairalastair! (C) Copyright 2026- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! program dummy use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('drhook_region',0,zhook_handle) call dr_hook('drhook_region',1,zhook_handle) stop end program dummy././@LongLink0000644000000000000000000000014700000000000011605 Lustar rootrootfiat-ecmwf-2.0.0/tests/drhook/drhook_core/drhook_fn_process_options/drhook_separate_stream_regex.cmakefiat-ecmwf-2.0.0/tests/drhook/drhook_core/drhook_fn_process_options/drhook_separate_stream_regex.cma0000664000175000017500000000457415157200431034540 0ustar alastairalastair# (C) Copyright 2026 ECMWF. # # This file is covered by the LICENSING file in the root of this project. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. function( run_command COMMAND ) set( COMMAND ${ARGV} ) string(REPLACE ";" " " PRINT_COMMAND "${COMMAND}" ) message( "${PRINT_COMMAND}" ) execute_process( COMMAND ${COMMAND} RESULT_VARIABLE res OUTPUT_VARIABLE stdout ERROR_VARIABLE stderr ) if( DEFINED PASS_REGULAR_EXPRESSION_STDOUT ) string(REGEX MATCH "${PASS_REGULAR_EXPRESSION_STDOUT}" stdout_pass_match "${stdout}" ) endif() if( DEFINED FAIL_REGULAR_EXPRESSION_STDOUT ) string(REGEX MATCH "${FAIL_REGULAR_EXPRESSION_STDOUT}" stdout_fail_match "${stdout}" ) endif() if( DEFINED PASS_REGULAR_EXPRESSION_STDERR ) string(REGEX MATCH "${PASS_REGULAR_EXPRESSION_STDERR}" stderr_pass_match "${stderr}" ) endif() if( DEFINED FAIL_REGULAR_EXPRESSION_STDERR ) string(REGEX MATCH "${FAIL_REGULAR_EXPRESSION_STDERR}" stderr_fail_match "${stderr}" ) endif() if ( DEFINED PASS_REGULAR_EXPRESSION_STDOUT AND NOT stdout_pass_match ) message( FATAL_ERROR "Test failed: Could not find pass regex [${PASS_REGULAR_EXPRESSION_STDOUT}] in program stdout [${stdout}]") endif() if ( DEFINED PASS_REGULAR_EXPRESSION_STDERR AND NOT stderr_pass_match ) message( FATAL_ERROR "Test failed: Could not find pass regex [${PASS_REGULAR_EXPRESSION_STDERR}] in program stderr [${stderr}]") endif() if ( DEFINED FAIL_REGULAR_EXPRESSION_STDOUT AND stdout_fail_match ) message( FATAL_ERROR "Test failed: Found fail regex [${FAIL_REGULAR_EXPRESSION_STDOUT}] in program stdout [${stdout}]") endif() if ( DEFINED FAIL_REGULAR_EXPRESSION_STDERR AND stderr_fail_match ) message( FATAL_ERROR "Test failed: Found fail regex [${FAIL_REGULAR_EXPRESSION_STDERR}] in program stderr [${stderr}]") endif() if( (stdout_pass_match AND stderr_pass_match) AND NOT (stdout_fail_match OR stderr_fail_match)) message( "Test succeeded: All regexes matched") endif() endfunction() message( "Running test ${EXECUTABLE} ... ") run_command( ${LAUNCH} ${EXECUTABLE} ) message( "Running test ${EXECUTABLE} ... done")fiat-ecmwf-2.0.0/tests/drhook/drhook_core/drhook_fn_process_options/CMakeLists.txt0000664000175000017500000001616515157200431030676 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # ecbuild_add_executable( TARGET fiat_test_drhook_fn_process_options_dummy SOURCES dummy.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_CANNONICAL_NAMES ALL MEMORY TIMES HEAP STACK RSS PAGING WALLTIME CPUTIME CALLS MEMPROF WALLPROF COUNTERS CPUPROF TRIM SELF NOSELF NOPROPAGATE_SIGNALS NOSIZEINFO CLUSTERINFO CALLPATH NONE) list( JOIN DRHOOK_OPTS_CANNONICAL_NAMES "," DRHOOK_OPTS_CANNONICAL_NAMES_STRING ) add_test( NAME fiat_test_drhook_fn_process_options_cannon_names COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION_STDERR=DR_HOOK_OPT=\"${DRHOOK_OPTS_CANNONICAL_NAMES_STRING}\"" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_cannon_names PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_CANNONICAL_NAMES_STRING}" ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_SHORT1_NAMES MEM TIME HWM STK PAG WALL CPU COUNT PROF NOPROP NOSIZE CLUSTER) list( JOIN DRHOOK_OPTS_SHORT1_NAMES "," DRHOOK_OPTS_SHORT1_NAMES_STRING ) set(DRHOOK_OPTS_SHORT1_CANNONICAL_NAMES MEMORY TIMES HEAP STACK PAGING WALLTIME CPUTIME CALLS WALLPROF NOPROPAGATE_SIGNALS NOSIZEINFO CLUSTERINFO) list( JOIN DRHOOK_OPTS_SHORT1_CANNONICAL_NAMES "," DRHOOK_OPTS_SHORT1_CANNONICAL_NAMES_STRING ) add_test( NAME fiat_test_drhook_fn_process_options_short_names1 COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION_STDERR=DR_HOOK_OPT=\"${DRHOOK_OPTS_SHORT1_CANNONICAL_NAMES_STRING}\"" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_short_names1 PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_SHORT1_NAMES_STRING}" ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_SHORT2_NAMES CYCLES NOPROPAGATE) list( JOIN DRHOOK_OPTS_SHORT2_NAMES "," DRHOOK_OPTS_SHORT2_NAMES_STRING ) set(DRHOOK_OPTS_SHORT2_CANNONICAL_NAMES WALLPROF NOPROPAGATE_SIGNALS) list( JOIN DRHOOK_OPTS_SHORT2_CANNONICAL_NAMES "," DRHOOK_OPTS_SHORT2_CANNONICAL_NAMES_STRING ) add_test( NAME fiat_test_drhook_fn_process_options_short_names2 COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION_STDERR=DR_HOOK_OPT=\"${DRHOOK_OPTS_SHORT2_CANNONICAL_NAMES_STRING}\"" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_short_names2 PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_SHORT2_NAMES_STRING}" ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_DELIMITED_STRING "ALL,MEMORY TIMES\tHEAP/STACK") add_test( NAME fiat_test_drhook_fn_process_options_delimiters COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION_STDERR=DR_HOOK_OPT=\"ALL,MEMORY,TIMES,HEAP,STACK\"" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_delimiters PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_DELIMITED_STRING}" ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_ONLY_INVALID_STRING "foo,bar, ,,") add_test( NAME fiat_test_drhook_fn_process_options_only_invalid COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION_STDERR=Warning - no match for DR_HOOK_OPT=\"FOO,BAR\"" "-DFAIL_REGULAR_EXPRESSION_STDERR=] DR_HOOK_OPT=\"" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_only_invalid PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_ONLY_INVALID_STRING}" ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_INVALID_STRING "foo,all,bar, ,,NONE") add_test( NAME fiat_test_drhook_fn_process_options_invalid COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION_STDERR=DR_HOOK_OPT=\"ALL,NONE\"\n.*Warning - no match for DR_HOOK_OPT=\"FOO,BAR\"" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_invalid PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_INVALID_STRING}" ) # ------------------------------------------------------------------------------ set(DRHOOK_OPTS_EMPTY_STRING ",, ,") add_test( NAME fiat_test_drhook_fn_process_options_empty COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" # ${LAUNCH} is inherited from tests/CMakeLists.txt "-DLAUNCH=${LAUNCH}" "-DFAIL_REGULAR_EXPRESSION_STDERR=(DR_HOOK_OPT=)|(Warning - no match for DR_HOOK_OPT=)" "-DFAIL_REGULAR_EXPRESSION_STDOUT=.+" -P ${CMAKE_CURRENT_SOURCE_DIR}/drhook_separate_stream_regex.cmake ) set_tests_properties(fiat_test_drhook_fn_process_options_empty PROPERTIES ENVIRONMENT "DR_HOOK=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=${DRHOOK_OPTS_EMPTY_STRING}" ) fiat-ecmwf-2.0.0/tests/drhook/drhook_core/CMakeLists.txt0000664000175000017500000000111315157200431023377 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # file(GLOB subdirs RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *) foreach(subdir ${subdirs}) if(IS_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/${subdir}) add_subdirectory(${subdir}) endif() endforeach()fiat-ecmwf-2.0.0/tests/drhook/drhook_ex5.F900000664000175000017500000000267215157200431020703 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_ex5 use mpl_module use yomhook, only : jphook, dr_hook use sdl_mod, only : sdl_traceback implicit none integer j, numargs integer jpe, npes, mype character(len=256) arg, env real(jphook) :: zhook_handle call mpl_init(ldinfo=.false.) call dr_hook('drhook_ex5',0,zhook_handle) npes = mpl_nproc() mype = mpl_myrank() do jpe=1,npes if (jpe == mype) then write(0,1000) mype,& & ': Basic MPL/MPI implementation works : # of MPI-tasks = ',npes numargs = mpl_iargc() write(0,1000) mype,& & ': Number of args = ',numargs do j=0,numargs call mpl_getarg(j,arg) write(0,1001) mype, ': arg#', j, ' "'//trim(arg)//'"' enddo call get_environment_variable('MPICH_ROOT',env) write(0,1002) mype, ': env MPICH_ROOT="'//trim(env)//'"' call ec_flush(0) endif call mpl_barrier() enddo call mpl_barrier() call sdl_traceback() ! Testing traceback, too call mpl_end() 1000 format(i5,a,i5) 1001 format(i5,a,i2,a) 1002 format(i5,a) call dr_hook('drhook_ex5',1,zhook_handle) end program drhook_ex5 fiat-ecmwf-2.0.0/tests/drhook/drhook_ex4.c0000664000175000017500000000351415157200431020562 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include #include "drhook.h" #ifdef __INTEL_COMPILER // Otherwise SIGFPE is not triggered #pragma STDC FENV_ACCESS ON #endif static int trig_sigfpe = 0; void set_trig_sigfpe() { char* env = getenv("SIGFPE"); trig_sigfpe = env ? atoi(env) : 1; } double mysin(double x) { DRHOOK_START(mysin); { double div = 180; static int jcnt = 0; if (trig_sigfpe && (++jcnt%15000 == 0)) { fprintf(stderr, "Trigger div-by-zero\n" ); div = 0; /* Trigger divide-by-zero i.e. "My sin" ;-) */ } x = sin(x/div); } DRHOOK_END(); /* mysin */ return x; } double mycos(double x) { DRHOOK_START(mycos); x = 1 - mysin(x); DRHOOK_END(); /* mycos */ return x; } double mysqrt(double x) { DRHOOK_START(mysqrt); x = sqrt(x); DRHOOK_END(); /* mysqrt */ return x; } double sub(int j) { double ans = 0; DRHOOK_START(sub); { int i, i1 = (j-1)*100, i2 = j*100; for (i=i1; i 0) call sub2(a(1)) call dr_hook('sub1',1,zhook_handle) end subroutine sub1 subroutine sub2(s) use yomhook, only : jphook, dr_hook implicit none real(8), intent(inout) :: s real(jphook) :: zhook_handle call dr_hook('sub2',0,zhook_handle) write(0,*) s s = 1._8/s ! divide by zero call dr_hook('sub2',1,zhook_handle) end subroutine sub2 fiat-ecmwf-2.0.0/tests/drhook/drhook_papi/0000775000175000017500000000000015157200431020644 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/drhook/drhook_papi/drhook_papi_mpi.F900000664000175000017500000000163315157200431024273 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_papi_mpi use mpl_module use yomhook, only : jphook, dr_hook use sdl_mod, only : sdl_traceback implicit none integer jpe, npes, mype, a character(len=256) arg, env real(jphook) :: zhook_handle call mpl_init(ldinfo=.false.) call dr_hook('drhook_papi_mpi',0,zhook_handle) npes = mpl_nproc() mype = mpl_myrank() do jpe=1,npes if (mype == jpe) then a = a + jpe endif enddo call mpl_barrier() call dr_hook('drhook_papi_mpi',1,zhook_handle) call mpl_end() end program drhook_papi_mpi fiat-ecmwf-2.0.0/tests/drhook/drhook_papi/drhook_papi_user_filename.F900000664000175000017500000000127615157200431026327 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_papi_user_filename use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle integer :: a call dr_hook('drhook_papi_user_filename', 0, zhook_handle) a = 1 a = a + a call dr_hook('drhook_papi_user_filename', 1, zhook_handle) end program drhook_papi_user_filename fiat-ecmwf-2.0.0/tests/drhook/drhook_papi/drhook_papi_basic.F900000664000175000017500000000123715157200431024567 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_papi_basic use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle integer :: a call dr_hook('drhook_papi_basic', 0, zhook_handle) a = 1 a = a + a call dr_hook('drhook_papi_basic', 1, zhook_handle) end program drhook_papi_basic fiat-ecmwf-2.0.0/tests/drhook/drhook_papi/drhook_papi_user_counters_more_than_max.F900000664000175000017500000000136615157200431031312 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_papi_user_counters_more_than_max use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle integer :: a call dr_hook('drhook_papi_user_counters_more_than_max', 0, zhook_handle) a = 1 a = a + a call dr_hook('drhook_papi_user_counters_more_than_max', 1, zhook_handle) end program drhook_papi_user_counters_more_than_max fiat-ecmwf-2.0.0/tests/drhook/drhook_papi/drhook_papi_user_counters.F900000664000175000017500000000127615157200431026411 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_papi_user_counters use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle integer :: a call dr_hook('drhook_papi_user_counters', 0, zhook_handle) a = 1 a = a + a call dr_hook('drhook_papi_user_counters', 1, zhook_handle) end program drhook_papi_user_counters fiat-ecmwf-2.0.0/tests/drhook/drhook_papi/CMakeLists.txt0000664000175000017500000001212715157200431023407 0ustar alastairalastair# # (C) Copyright 2024- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # # Test basic implementation ecbuild_add_executable( TARGET drhook_papi_basic SOURCES drhook_papi_basic.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_PAPI NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_papi_basic COMMAND drhook_papi_basic ENVIRONMENT DR_HOOK=1 DR_HOOK_OPT=COUNTERS CONDITION HAVE_DR_HOOK_PAPI ) if (TEST fiat_test_drhook_papi_basic) set_tests_properties(fiat_test_drhook_papi_basic PROPERTIES PASS_REGULAR_EXPRESSION "Writing counter information of proc#1 into file" ) endif() ecbuild_add_test( TARGET fiat_test_drhook_papi_basic_valid_csv TYPE SCRIPT # Just making sure it's not an empty file COMMAND "find" ARGS "." "-name" "drhook.prof.1.csv" "-type" "f" "-size" "+100c" CONDITION HAVE_DR_HOOK_PAPI ) if (TEST fiat_test_drhook_papi_basic_valid_csv) set_tests_properties(fiat_test_drhook_papi_basic_valid_csv PROPERTIES DEPENDS fiat_test_drhook_papi_basic PASS_REGULAR_EXPRESSION "drhook.prof.1.csv" ) endif() # Test MPI implementation ecbuild_add_executable( TARGET drhook_papi_mpi SOURCES drhook_papi_mpi.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_PAPI AND HAVE_MPI NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_papi_mpi COMMAND drhook_papi_mpi MPI 5 ENVIRONMENT DR_HOOK=1 DR_HOOK_OPT=COUNTERS DR_HOOK_PROFILE=fiat_test_drhook_papi_mpi CONDITION HAVE_DR_HOOK_PAPI AND HAVE_MPI ) ecbuild_add_test( TARGET fiat_test_drhook_papi_mpi_valid_csv TYPE SCRIPT # Just making sure it's not an empty file # We have to do this weird thing with bash so that we can # use a redirect. CMake tests are really basic... COMMAND "bash" ARGS "-c" "find . -name 'fiat_test_drhook_papi_mpi.[1-5].csv' -type f -size +100c | wc -l" CONDITION HAVE_DR_HOOK_PAPI AND HAVE_MPI ) if (TEST fiat_test_drhook_papi_mpi_valid_csv) set_tests_properties(fiat_test_drhook_papi_mpi_valid_csv PROPERTIES DEPENDS fiat_test_drhook_papi_mpi PASS_REGULAR_EXPRESSION "5" ) endif() # Test user specified output file names ecbuild_add_executable( TARGET drhook_papi_user_filename SOURCES drhook_papi_user_filename.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_PAPI NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_papi_user_filename COMMAND drhook_papi_user_filename ENVIRONMENT DR_HOOK=1 DR_HOOK_OPT=COUNTERS DR_HOOK_PROFILE=fiat_test_drhook_papi_user_filename CONDITION HAVE_DR_HOOK_PAPI ) ecbuild_add_test( TARGET fiat_test_drhook_papi_user_filename_valid_csv TYPE SCRIPT # Just making sure it's not an empty file COMMAND "find" ARGS "." "-name" "fiat_test_drhook_papi_user_filename.1.csv" "-type" "f" CONDITION HAVE_DR_HOOK_PAPI ) if (TEST fiat_test_drhook_papi_user_filename_valid_csv) set_tests_properties(fiat_test_drhook_papi_user_filename_valid_csv PROPERTIES DEPENDS fiat_test_drhook_papi_user_filename PASS_REGULAR_EXPRESSION "fiat_test_drhook_papi_user_filename.1.csv" ) endif() # Test user specified counters ecbuild_add_executable( TARGET drhook_papi_user_counters SOURCES drhook_papi_user_counters.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_PAPI NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_papi_user_counters COMMAND drhook_papi_user_counters ENVIRONMENT DR_HOOK=1 DR_HOOK_OPT=COUNTERS DR_HOOK_PAPI_COUNTERS=PAPI_TOT_INS DR_HOOK_PROFILE=fiat_test_drhook_papi_user_counters CONDITION HAVE_DR_HOOK_PAPI ) if (TEST fiat_test_drhook_papi_user_counters) set_tests_properties(fiat_test_drhook_papi_user_counters PROPERTIES PASS_REGULAR_EXPRESSION "PAPI_TOT_INS" ) endif() # Test user specified counters going over max allowed ecbuild_add_executable( TARGET drhook_papi_user_counters_more_than_max SOURCES drhook_papi_user_counters_more_than_max.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_PAPI NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_papi_user_counters_more_than_max COMMAND drhook_papi_user_counters_more_than_max ENVIRONMENT DR_HOOK=1 DR_HOOK_OPT=COUNTERS DR_HOOK_PAPI_COUNTERS=PAPI_TOT_CYC,PAPI_FP_OPS,PAPI_L1_DCA,PAPI_L2_DCM,PAPI_TOT_INS DR_HOOK_PROFILE=drhook_papi_user_counters_more_than_max CONDITION HAVE_DR_HOOK_PAPI ) if (TEST fiat_test_drhook_papi_user_counters_more_than_max) set_tests_properties(fiat_test_drhook_papi_user_counters_more_than_max PROPERTIES FAIL_REGULAR_EXPRESSION "PAPI_TOT_INS" ) endif() fiat-ecmwf-2.0.0/tests/drhook/README.md0000664000175000017500000000022415157200431017622 0ustar alastairalastairThese scripts and logs were ported from the ODB Not everything is tested as it should. The tests should be improved to check the profiling options fiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/0000775000175000017500000000000015157200431020712 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/drhook_nvtx_basic_c.c0000664000175000017500000000105115157200431025063 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include "drhook.h" int main(int argc, char *argv[]) { DRHOOK_START("main"); printf("Hello World!\n"); DRHOOK_END(); return 0; } fiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/drhook_nvtx_skip_spam_regions.F900000664000175000017500000000167715157200431027346 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_nvtx_skip_spam_regions use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('drhook_nvtx_skip_spam_regions', 0, zhook_handle) call foo(0) call dr_hook('drhook_nvtx_skip_spam_regions', 1, zhook_handle) contains recursive subroutine foo (depth) integer, intent(in) :: depth real(jphook) :: zhook_handle call dr_hook('foo', 0, zhook_handle) if (depth < 10) then call foo(depth + 1) end if call dr_hook('foo', 1, zhook_handle) end subroutine end program drhook_nvtx_skip_spam_regions fiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/drhook_nvtx_no_skip_spam_regions.F900000664000175000017500000000211215157200431030023 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_nvtx_no_skip_spam_regions use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('drhook_nvtx_no_skip_spam_regions', 0, zhook_handle) call foo(-1) call foo(0) call dr_hook('drhook_nvtx_no_skip_spam_regions', 1, zhook_handle) contains recursive subroutine foo (depth) integer, intent(in) :: depth real(jphook) :: zhook_handle call dr_hook('foo', 0, zhook_handle) if (depth == -1) then call sleep(1) call dr_hook('foo', 1, zhook_handle) return end if if (depth < 10) then call foo(depth + 1) end if call dr_hook('foo', 1, zhook_handle) end subroutine end program drhook_nvtx_no_skip_spam_regions fiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/drhook_nvtx_basic.F900000664000175000017500000000345415157200431024706 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! (C) Copyright 2024- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program fiat_test_drhook_nvtx_basic use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('fiat_test_drhook_nvtx_basic',0,zhook_handle) call sub (0) call dr_hook('fiat_test_drhook_nvtx_basic',1,zhook_handle) contains recursive subroutine sub (depth) integer :: depth character(len=128) :: clname real(jphook) :: zhook_handle integer :: i if (depth > irand (2, 4)) return do i = 1, len (clname) clname (i:i) = ' ' enddo do i = 1, 16 clname (i:i) = char (irand (ichar ('A'), ichar ('Z'))) enddo do i = 1, depth write (*, '(" ")', advance='no') enddo write (*, '(" - ",A)') clname (1:16) call dr_hook(clname,0,zhook_handle) call sleep (real (irand (10, 200))) do i = 1, irand (1, 4) call sub (depth+1) call sleep (real (irand (10, 200))) enddo call dr_hook(clname,1,zhook_handle) end subroutine subroutine sleep (dt) implicit none real, intent (in) :: dt integer, dimension (8) :: t integer :: s1,s2,ms1,ms2 call date_and_time(values=t) ms1=(t(5)*3600+t(6)*60+t(7))*1000+t(8) do call date_and_time(values=t) ms2=(t(5)*3600+t(6)*60+t(7))*1000+t(8) if(ms2-ms1>=dt)exit enddo end subroutine sleep integer function irand (k1, k2) integer :: k1, k2 integer*8, save :: x = 2713 x = modulo (16807_8 * x, 2147483647_8) irand = k1 + modulo (x, int (k2-k1+1, 8)) end function end program fiat_test_drhook_nvtx_basic fiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/drhook_nvtx_mismatched_regions.F900000664000175000017500000000150415157200431027463 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_nvtx_mismatched_regions use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle, zhook_handle_a integer :: a, b call dr_hook('drhook_nvtx_mismatched_regions', 0, zhook_handle) ! Region A Start call dr_hook('a', 0, zhook_handle_a) a = 1 ! Region A Stop call dr_hook('this_is_not_a!', 1, zhook_handle_a) call dr_hook('drhook_nvtx_mismatched_regions', 1, zhook_handle) end program drhook_nvtx_mismatched_regions fiat-ecmwf-2.0.0/tests/drhook/drhook_nvtx/CMakeLists.txt0000664000175000017500000001004315157200431023450 0ustar alastairalastair# # (C) Copyright 2024- ECMWF. # (C) Copyright 2024- Meteo-France. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # # Test basic implementation ecbuild_add_executable( TARGET drhook_nvtx_basic SOURCES drhook_nvtx_basic.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_NVTX NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_nvtx_basic TYPE SCRIPT COMMAND "nsys" ARGS "profile" "--force-overwrite=true" "--trace=nvtx" "--kill=none" "--output=nsys.drhook_nvtx_basic.qdrep" "./drhook_nvtx_basic" ENVIRONMENT DR_HOOK=1 DR_HOOK_NVTX=1 CONDITION HAVE_DR_HOOK_NVTX ) # Test basic implementation in C ecbuild_add_executable( TARGET drhook_nvtx_basic_c SOURCES drhook_nvtx_basic_c.c LIBS ${fiatlib} LINKER_LANGUAGE C CONDITION HAVE_DR_HOOK_NVTX NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_nvtx_basic_c TYPE SCRIPT COMMAND "nsys" ARGS "profile" "--force-overwrite=true" "--trace=nvtx" "--kill=none" "--output=nsys.drhook_nvtx_basic_c.qdrep" "./drhook_nvtx_basic_c" ENVIRONMENT DR_HOOK=1 DR_HOOK_NVTX=1 CONDITION HAVE_DR_HOOK_NVTX ) # Test abort on mismatched region names ecbuild_add_executable( TARGET drhook_nvtx_mismatched_regions SOURCES drhook_nvtx_mismatched_regions.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_NVTX NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_nvtx_mismatched_regions TYPE SCRIPT COMMAND "nsys" ARGS "profile" "--force-overwrite=true" "--trace=nvtx" "--kill=none" "--output=nsys.drhook_nvtx_mismatched_regions.qdrep" "./drhook_nvtx_mismatched_regions" ENVIRONMENT DR_HOOK=1 DR_HOOK_NVTX=1 CONDITION HAVE_DR_HOOK_NVTX ) if (TEST fiat_test_drhook_nvtx_mismatched_regions) set_tests_properties(fiat_test_drhook_nvtx_mismatched_regions PROPERTIES WILL_FAIL TRUE ) endif() # Test skip on spammy regions ecbuild_add_executable( TARGET drhook_nvtx_skip_spam_regions SOURCES drhook_nvtx_skip_spam_regions.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_NVTX NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_nvtx_skip_spam_regions TYPE SCRIPT COMMAND "nsys" ARGS "profile" "--force-overwrite=true" "--trace=nvtx" "--kill=none" "--output=nsys.drhook_nvtx_skip_spam_regions.qdrep" "./drhook_nvtx_skip_spam_regions" ENVIRONMENT DR_HOOK=1 DR_HOOK_NVTX=1 DR_HOOK_SILENT=0 CONDITION HAVE_DR_HOOK_NVTX ) if (TEST fiat_test_drhook_nvtx_skip_spam_regions) set_tests_properties(fiat_test_drhook_nvtx_skip_spam_regions PROPERTIES PASS_REGULAR_EXPRESSION "DRHOOK:NVTX: Skipping closing of region foo" PASS_REGULAR_EXPRESSION "DRHOOK:NVTX: Skipping opening of region foo" ) endif() # Test not to skip on spammy regions with long runtimes ecbuild_add_executable( TARGET drhook_nvtx_no_skip_spam_regions SOURCES drhook_nvtx_no_skip_spam_regions.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_DR_HOOK_NVTX NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_nvtx_no_skip_spam_regions TYPE SCRIPT COMMAND "nsys" ARGS "profile" "--force-overwrite=true" "--trace=nvtx" "--kill=none" "--output=nsys.drhook_nvtx_no_skip_spam_regions.qdrep" "./drhook_nvtx_no_skip_spam_regions" ENVIRONMENT DR_HOOK=1 DR_HOOK_NVTX=1 DR_HOOK_SILENT=0 CONDITION HAVE_DR_HOOK_NVTX ) if (TEST fiat_test_drhook_nvtx_no_skip_spam_regions) set_tests_properties(fiat_test_drhook_nvtx_no_skip_spam_regions PROPERTIES FAIL_REGULAR_EXPRESSION "DRHOOK:NVTX: Skipping closing of region foo" FAIL_REGULAR_EXPRESSION "DRHOOK:NVTX: Skipping opening of region foo" ) endif() fiat-ecmwf-2.0.0/tests/drhook/drhook_ex.log0000664000175000017500000003474315157200431021045 0ustar alastairalastair #------------------------------------------------------------------------- # Example#1 : Generate Dr.Hook, run and fail in divide by zero #------------------------------------------------------------------------- env DR_HOOK=1 ./drhook_ex1.x || : TIME:(12:06) env DR_HOOK=1 ./drhook_ex1.x signal_drhook(SIGABRT=6): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGBUS=10): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGSEGV=11): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGILL=4): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGEMT=7): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGFPE=8): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGTRAP=5): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGINT=2): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGQUIT=3): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGTERM=15): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGXCPU=24): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGDANGER=33): New handler installed at 0x100096b0; old preserved at 0x0 signal_drhook(SIGSYS=12): New handler installed at 0x100096b0; old preserved at 0x0 >>>pm_init() for ECMWF/OpenMP-tid#1, pthread_self()=1 [myproc#1,tid#1,pid#1536242]: Received signal#8 (SIGFPE) :: 113MB (heap), 85MB (rss), 0MB (stack), 51 (paging), nsigs 1, time 0.23 Activating SIGALRM=14 and calling alarm(10), time = 0.23 JSETSIG: sl->active = 0 signal_drhook(SIGALRM=14): New handler installed at 0x100096b0; old preserved at 0x0 tid#1 starting drhook traceback, time = 0.23 [myproc#1,tid#1,pid#1536242]: DRHOOK_EX1 [myproc#1,tid#1,pid#1536242]: SUB1 [myproc#1,tid#1,pid#1536242]: SUB2 tid#1 starting sigdump traceback, time = 0.23 Signal received: SIGFPE - Floating-point exception Signal generated for floating-point exception: FP division by zero Instruction that generated the exception: fdiv fr00,fr01,fr00 Source Operand values: fr01 = 1.00000000000000e+00 fr00 = 0.00000000000000e+00 Traceback: Offset 0x00000068 in procedure sub2_, near line 36 in file _drhook_ex1.F90 Offset 0x00000068 in procedure sub1_, near line 25 in file _drhook_ex1.F90 Offset 0x00000398 in procedure drhook_ex1, near line 13 in file _drhook_ex1.F90 --- End of call chain --- Done tracebacks, calling exit with sig=8, time = 0.24 TIME:(12:06) : #------------------------------------------------------------------------- # Example#2 : With the previous case fixed experience with watch point #------------------------------------------------------------------------- env DR_HOOK=1 ./drhook_ex2.x || : TIME:(12:06) env DR_HOOK=1 ./drhook_ex2.x signal_drhook(SIGABRT=6): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGBUS=10): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGSEGV=11): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGILL=4): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGEMT=7): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGFPE=8): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGTRAP=5): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGINT=2): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGQUIT=3): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGTERM=15): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGXCPU=24): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGDANGER=33): New handler installed at 0x10009e68; old preserved at 0x0 signal_drhook(SIGSYS=12): New handler installed at 0x10009e68; old preserved at 0x0 >>>pm_init() for ECMWF/OpenMP-tid#1, pthread_self()=1 ***Warning: Watch point 'MAIN: array A(N)' was created for address 0xffffedb8 (800 bytes, tid#1) : crc32=321238578 ***Error: Watch point 'MAIN: array A(N)' at address 0xffffedb8 has changed (detected in tid#1 when leaving routine SUB2) : new crc32=3532715324 [myproc#1,tid#1,pid#1536248]: Received signal#6 (SIGABRT) :: 113MB (heap), 85MB (rss), 0MB (stack), 25 (paging), nsigs 1, time 0.19 Activating SIGALRM=14 and calling alarm(10), time = 0.19 JSETSIG: sl->active = 0 signal_drhook(SIGALRM=14): New handler installed at 0x10009e68; old preserved at 0x0 tid#1 starting drhook traceback, time = 0.19 [myproc#1,tid#1,pid#1536248]: DRHOOK_EX2 [myproc#1,tid#1,pid#1536248]: SUB1 [myproc#1,tid#1,pid#1536248]: SUB2 tid#1 starting sigdump traceback, time = 0.19 Signal received: SIGABRT - Abort Traceback: Offset 0x0000009c in procedure pthread_kill Offset 0x0000005c in procedure _p_raise Offset 0x00000024 in procedure c_drhook_raise_, near line 2866 in file drhook.c Offset 0x00000194 in procedure check_watch, near line 1786 in file drhook.c Offset 0x0000010c in procedure c_drhook_end_, near line 1985 in file drhook.c Offset 0x000001f8 in procedure dr_hook_util_, near line 37 in file dr_hook_util.F90 Offset 0x00000038 in procedure __yomhook_NMOD_dr_hook_default_, near line 48 in file yomhook.F90 Offset 0x00000090 in procedure sub2_, near line 41 in file _drhook_ex2.F90 Offset 0x00000068 in procedure sub1_, near line 28 in file _drhook_ex2.F90 Offset 0x00000428 in procedure drhook_ex2, near line 16 in file _drhook_ex2.F90 --- End of call chain --- Done tracebacks, calling exit with sig=6, time = 0.20 TIME:(12:06) : #------------------------------------------------------------------------- # Example#3 : Experience with different profilings. Also silence Dr.Hook! #------------------------------------------------------------------------- export DR_HOOK=1 export DR_HOOK_SILENT=1 export DR_HOOK_SHOW_PROCESS_OPTIONS=0 #-- Wall clock profile env DR_HOOK_OPT=wallprof ./drhook_ex3.x TIME:(12:06) env DR_HOOK_OPT=wallprof ./drhook_ex3.x >>>pm_init() for ECMWF/OpenMP-tid#1, pthread_self()=1 Writing profiling information of proc#1 into file 'drhook.prof.0' Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120605 Instrumentation ended : 20050316 120605 Instrumentation overhead: 32.77% Wall-time is 0.00 sec on proc#1 (-1 procs, 8 threads) Thread#1: 0.00 sec (100.00%) Thread#2: 0.00 sec (0.00%) Thread#3: 0.00 sec (0.00%) Thread#4: 0.00 sec (0.00%) Thread#5: 0.00 sec (0.00%) Thread#6: 0.00 sec (0.00%) Thread#7: 0.00 sec (0.00%) Thread#8: 0.00 sec (0.00%) cat drhook.prof.0 TIME:(12:06) cat drhook.prof.0 Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120605 Instrumentation ended : 20050316 120605 Instrumentation overhead: 32.77% Memory usage : 113 MBytes (heap), 85 MBytes (rss), 0 MBytes (stack), 21 (paging) Wall-time is 0.00 sec on proc#1 (-1 procs, 8 threads) Thread#1: 0.00 sec (100.00%) Thread#2: 0.00 sec (0.00%) Thread#3: 0.00 sec (0.00%) Thread#4: 0.00 sec (0.00%) Thread#5: 0.00 sec (0.00%) Thread#6: 0.00 sec (0.00%) Thread#7: 0.00 sec (0.00%) Thread#8: 0.00 sec (0.00%) # % Time Cumul Self Total # of calls Self Total Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) ms/call ms/call 1 53.04 0.001 0.001 0.002 2500 0.00 0.00 SUB2@1 2 45.04 0.002 0.001 0.003 100 0.01 0.03 SUB1@1 3 1.92 0.002 0.000 0.003 1 0.05 3.02 DRHOOK_EX3@1 #-- CPU-time profile env DR_HOOK_OPT=cpuprof ./drhook_ex3.x TIME:(12:06) env DR_HOOK_OPT=cpuprof ./drhook_ex3.x >>>pm_init() for ECMWF/OpenMP-tid#1, pthread_self()=1 Writing profiling information of proc#1 into file 'drhook.prof.0' Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120605 Instrumentation ended : 20050316 120606 Instrumentation overhead: 100.00% Total CPU-time is 0.00 sec on proc#1 (-1 procs, 8 threads) Thread#1: 0.00 sec (0.00%) Thread#2: 0.00 sec (0.00%) Thread#3: 0.00 sec (0.00%) Thread#4: 0.00 sec (0.00%) Thread#5: 0.00 sec (0.00%) Thread#6: 0.00 sec (0.00%) Thread#7: 0.00 sec (0.00%) Thread#8: 0.00 sec (0.00%) cat drhook.prof.0 TIME:(12:06) cat drhook.prof.0 Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120605 Instrumentation ended : 20050316 120606 Instrumentation overhead: 100.00% Memory usage : 113 MBytes (heap), 85 MBytes (rss), 0 MBytes (stack), 0 (paging) Total CPU-time is 0.00 sec on proc#1 (-1 procs, 8 threads) Thread#1: 0.00 sec (0.00%) Thread#2: 0.00 sec (0.00%) Thread#3: 0.00 sec (0.00%) Thread#4: 0.00 sec (0.00%) Thread#5: 0.00 sec (0.00%) Thread#6: 0.00 sec (0.00%) Thread#7: 0.00 sec (0.00%) Thread#8: 0.00 sec (0.00%) # % Time Cumul Self Total # of calls Self Total Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) ms/call ms/call 1 0.00 0.000 0.000 0.010 1 0.00 10.00 DRHOOK_EX3@1 2 0.00 0.000 0.000 0.010 100 0.00 0.10 SUB1@1 3 0.00 0.000 0.000 0.010 2500 0.00 0.00 SUB2@1 #-- Mflop-counter profile env DR_HOOK_OPT=hpmprof ./drhook_ex3.x TIME:(12:06) env DR_HOOK_OPT=hpmprof ./drhook_ex3.x >>>pm_init() for ECMWF/OpenMP-tid#1, pthread_self()=1 Writing profiling information of proc#1 into file 'drhook.prof.0' Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120606 Instrumentation ended : 20050316 120606 Instrumentation overhead: 7.37% Wall-time is 0.01 sec on proc#1, 15 MFlops (ops#0*10^6), 672 MIPS (ops#6*10^6) (-1 procs, 8 threads) Thread#1: 0.01 sec (100.00%), 15 MFlops (ops#0*10^6), 672 MIPS (ops#6*10^6) Thread#2: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#3: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#4: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#5: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#6: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#7: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#8: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) cat drhook.prof.0 TIME:(12:06) cat drhook.prof.0 Profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120606 Instrumentation ended : 20050316 120606 Instrumentation overhead: 7.37% Memory usage : 113 MBytes (heap), 85 MBytes (rss), 0 MBytes (stack), 0 (paging) Wall-time is 0.01 sec on proc#1, 15 MFlops (ops#0*10^6), 672 MIPS (ops#6*10^6) (-1 procs, 8 threads) Thread#1: 0.01 sec (100.00%), 15 MFlops (ops#0*10^6), 672 MIPS (ops#6*10^6) Thread#2: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#3: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#4: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#5: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#6: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#7: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) Thread#8: 0.00 sec (0.00%), 0 MFlops (ops#0*10^6), 0 MIPS (ops#0*10^6) # % Time Cumul Self Total # of calls MIPS MFlops Div-% Routine@ (Size; Size/sec; AvgSize/call) (self) (sec) (sec) (sec) 1 49.15 0.004 0.004 0.009 100 726 17 13.4 SUB1@1 2 48.82 0.008 0.004 0.005 2500 618 12 4.5 SUB2@1 3 2.04 0.009 0.000 0.009 1 683 15 15.4 DRHOOK_EX3@1 #-- Memory profile (only) env DR_HOOK_OPT=memprof ./drhook_ex3.x TIME:(12:06) env DR_HOOK_OPT=memprof ./drhook_ex3.x >>>pm_init() for ECMWF/OpenMP-tid#1, pthread_self()=1 Writing memory-profiling information of proc#1 into file 'drhook.prof.0-mem' Memory-profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120606 Instrumentation ended : 20050316 120606 cat drhook.prof.0-mem TIME:(12:06) cat drhook.prof.0-mem Memory-profiling information for program='./drhook_ex3.x', proc#1: No. of instrumented routines called : 3 Instrumentation started : 20050316 120606 Instrumentation ended : 20050316 120606 Memory usage : 0 MBytes (max.seen), 0 MBytes (leaked), 113 MBytes (heap), 85 MBytes (max.rss), 0 MBytes (max.stack), 0 (paging) # Memory-% Self-alloc + Children Self-Leaked Heap Max.Stack Paging #Calls #Allocs #Frees Routine@ (self) (bytes) (bytes) (bytes) (bytes) (bytes) (delta) 1 0.00 0 0 0 118538400 7664 0 1 0 0 DRHOOK_EX3@1 2 0.00 0 0 0 118538400 7856 0 100 0 0 SUB1@1 3 0.00 0 0 0 118538400 8016 0 2500 0 0 SUB2@1 fiat-ecmwf-2.0.0/tests/drhook/drhook_ex3.F900000664000175000017500000000311115157200431020666 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! program drhook_ex3 use yomhook, only : jphook, dr_hook implicit none integer(4) :: n real(8), allocatable :: a(:) integer(4) :: j real(jphook) :: zhook_handle call dr_hook('drhook_ex3',0,zhook_handle) n = 100 allocate(a(n)) do j=1,n a(j) = j-1 enddo write(0,*)'drhook_ex3: sum#1 = ',sum(a) deallocate(a) n = 5 * n allocate(a(n)) do j=1,n a(j) = j + n enddo do j=1,n call sub1(a,j) enddo write(0,*)'drhook_ex3: sum#2 = ',sum(a) deallocate(a) n = n/10 allocate(a(-n:n)) do j=-n,n a(j) = j + 2*n enddo do j=1,n call sub1(a,j) enddo write(0,*)'drhook_ex3: sum#3 = ',sum(a) deallocate(a) call dr_hook('drhook_ex3',1,zhook_handle) end program drhook_ex3 subroutine sub1(a,n) use yomhook, only : jphook, dr_hook implicit none integer(4), intent(in) :: n real(8), intent(inout) :: a(n) integer(4) j real(jphook) :: zhook_handle call dr_hook('sub1',0,zhook_handle) do j=1,n if (mod(j,2) == 0) call sub2(a(j)) a(j) = 2*a(j) + 1 enddo call dr_hook('sub1',1,zhook_handle) end subroutine sub1 subroutine sub2(s) use yomhook, only : jphook, dr_hook implicit none real(8), intent(inout) :: s real(jphook) :: zhook_handle call dr_hook('sub2',0,zhook_handle) s = 1/(s+1) call dr_hook('sub2',1,zhook_handle) end subroutine sub2 fiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/0000775000175000017500000000000015157200431021052 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/drhook_roctx_skip_spam_regions.F900000664000175000017500000000170315157200431027634 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_roctx_skip_spam_regions use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('drhook_roctx_skip_spam_regions', 0, zhook_handle) call foo(0) call dr_hook('drhook_roctx_skip_spam_regions', 1, zhook_handle) contains recursive subroutine foo (depth) integer, intent(in) :: depth real(jphook) :: zhook_handle call dr_hook('foo', 0, zhook_handle) if (depth < 10) then call foo(depth + 1) end if call dr_hook('foo', 1, zhook_handle) end subroutine end program drhook_roctx_skip_spam_regions fiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/drhook_roctx_basic.F900000664000175000017500000000346015157200431025203 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! (C) Copyright 2024- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program fiat_test_drhook_roctx_basic use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('fiat_test_drhook_roctx_basic',0,zhook_handle) call sub (0) call dr_hook('fiat_test_drhook_roctx_basic',1,zhook_handle) contains recursive subroutine sub (depth) integer :: depth character(len=128) :: clname real(jphook) :: zhook_handle integer :: i if (depth > irand (2, 4)) return do i = 1, len (clname) clname (i:i) = ' ' enddo do i = 1, 16 clname (i:i) = char (irand (ichar ('A'), ichar ('Z'))) enddo do i = 1, depth write (*, '(" ")', advance='no') enddo write (*, '(" - ",A)') clname (1:16) call dr_hook(clname,0,zhook_handle) call sleep (real (irand (10, 200))) do i = 1, irand (1, 4) call sub (depth+1) call sleep (real (irand (10, 200))) enddo call dr_hook(clname,1,zhook_handle) end subroutine subroutine sleep (dt) implicit none real, intent (in) :: dt integer, dimension (8) :: t integer :: s1,s2,ms1,ms2 call date_and_time(values=t) ms1=(t(5)*3600+t(6)*60+t(7))*1000+t(8) do call date_and_time(values=t) ms2=(t(5)*3600+t(6)*60+t(7))*1000+t(8) if(ms2-ms1>=dt)exit enddo end subroutine sleep integer function irand (k1, k2) integer :: k1, k2 integer*8, save :: x = 2713 x = modulo (16807_8 * x, 2147483647_8) irand = k1 + modulo (x, int (k2-k1+1, 8)) end function end program fiat_test_drhook_roctx_basic fiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/drhook_roctx_no_skip_spam_regions.F900000664000175000017500000000211615157200431030327 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_roctx_no_skip_spam_regions use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle call dr_hook('drhook_roctx_no_skip_spam_regions', 0, zhook_handle) call foo(-1) call foo(0) call dr_hook('drhook_roctx_no_skip_spam_regions', 1, zhook_handle) contains recursive subroutine foo (depth) integer, intent(in) :: depth real(jphook) :: zhook_handle call dr_hook('foo', 0, zhook_handle) if (depth == -1) then call sleep(1) call dr_hook('foo', 1, zhook_handle) return end if if (depth < 10) then call foo(depth + 1) end if call dr_hook('foo', 1, zhook_handle) end subroutine end program drhook_roctx_no_skip_spam_regions fiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/drhook_roctx_mismatched_regions.F900000664000175000017500000000151015157200431027760 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. program drhook_roctx_mismatched_regions use yomhook, only : jphook, dr_hook implicit none real(jphook) :: zhook_handle, zhook_handle_a integer :: a, b call dr_hook('drhook_roctx_mismatched_regions', 0, zhook_handle) ! Region A Start call dr_hook('a', 0, zhook_handle_a) a = 1 ! Region A Stop call dr_hook('this_is_not_a!', 1, zhook_handle_a) call dr_hook('drhook_roctx_mismatched_regions', 1, zhook_handle) end program drhook_roctx_mismatched_regions fiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/drhook_roctx_basic_c.c0000664000175000017500000000105115157200431025363 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include "drhook.h" int main(int argc, char *argv[]) { DRHOOK_START("main"); printf("Hello World!\n"); DRHOOK_END(); return 0; } fiat-ecmwf-2.0.0/tests/drhook/drhook_roctx/CMakeLists.txt0000664000175000017500000000744315157200431023622 0ustar alastairalastair# # (C) Copyright 2024- ECMWF. # (C) Copyright 2024- Meteo-France. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # # Test basic implementation ecbuild_add_executable( TARGET drhook_roctx_basic SOURCES drhook_roctx_basic.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_roctx_basic TYPE SCRIPT COMMAND "rocprofv3" ARGS --marker-trace --output-file rocprofv3.drhook_roctx_basic --output-format pftrace -- ./drhook_roctx_basic ENVIRONMENT DR_HOOK=1 DR_HOOK_ROCTX=1 ) # Test basic implementation in C ecbuild_add_executable( TARGET drhook_roctx_basic_c SOURCES drhook_roctx_basic_c.c LIBS ${fiatlib} LINKER_LANGUAGE C NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_roctx_basic_c TYPE SCRIPT COMMAND "rocprofv3" ARGS --marker-trace --output-file rocprofv3.drhook_roctx_basic_c --output-format pftrace -- ./drhook_roctx_basic_c ENVIRONMENT DR_HOOK=1 DR_HOOK_ROCTX=1 ) # Test abort on mismatched region names ecbuild_add_executable( TARGET drhook_roctx_mismatched_regions SOURCES drhook_roctx_mismatched_regions.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_roctx_mismatched_regions TYPE SCRIPT COMMAND "rocprofv3" # Need to disable signal handlers because rocprof will just bounce the signal back to DrHook until it gets harakiri'ed. # DR_HOOK_OPT=NOPROPAGATE_SIGNALS alone isn't enough as intel compilers hang when rocprof passes the signal back due to them also having a signal handler. ARGS --disable-signal-handlers --marker-trace --output-file rocprofv3.drhook_roctx_mismatched_regions --output-format pftrace -- ./drhook_roctx_mismatched_regions ENVIRONMENT DR_HOOK=1 DR_HOOK_ROCTX=1 DR_HOOK_OPT=NOPROPAGATE_SIGNALS ) set_tests_properties(fiat_test_drhook_roctx_mismatched_regions PROPERTIES WILL_FAIL TRUE ) # Test skip on spammy regions ecbuild_add_executable( TARGET drhook_roctx_skip_spam_regions SOURCES drhook_roctx_skip_spam_regions.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_roctx_skip_spam_regions TYPE SCRIPT COMMAND "rocprofv3" ARGS --marker-trace --output-file rocprofv3.drhook_roctx_skip_spam_regions --output-format pftrace -- ./drhook_roctx_skip_spam_regions ENVIRONMENT DR_HOOK=1 DR_HOOK_ROCTX=1 DR_HOOK_SILENT=0 ) set_tests_properties(fiat_test_drhook_roctx_skip_spam_regions PROPERTIES PASS_REGULAR_EXPRESSION "DRHOOK:ROCTX: Skipping closing of region foo" PASS_REGULAR_EXPRESSION "DRHOOK:ROCTX: Skipping opening of region foo" ) # Test not to skip on spammy regions with long runtimes ecbuild_add_executable( TARGET drhook_roctx_no_skip_spam_regions SOURCES drhook_roctx_no_skip_spam_regions.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_drhook_roctx_no_skip_spam_regions TYPE SCRIPT COMMAND "rocprofv3" ARGS --marker-trace --output-file rocprofv3.drhook_roctx_no_skip_spam_regions --output-format pftrace -- ./drhook_roctx_no_skip_spam_regions ENVIRONMENT DR_HOOK=1 DR_HOOK_ROCTX=1 DR_HOOK_SILENT=0 ) set_tests_properties(fiat_test_drhook_roctx_no_skip_spam_regions PROPERTIES FAIL_REGULAR_EXPRESSION "DRHOOK:ROCTX: Skipping closing of region foo" FAIL_REGULAR_EXPRESSION "DRHOOK:ROCTX: Skipping opening of region foo" ) fiat-ecmwf-2.0.0/tests/drhook/drhook_ex2.F900000664000175000017500000000276715157200431020705 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! program drhook_ex2 use yomhook, only : jphook, dr_hook use dr_hook_watch_mod, only : dr_hook_watch implicit none integer(4) :: n real(8), allocatable :: a(:) integer(4) :: j character(len=256) a_out character(len=20) cn real(jphook) :: zhook_handle call dr_hook('drhook_ex2',0,zhook_handle) n = 5 allocate(a(n)) do j=1,n a(j) = j-1 enddo ! Watch & fail when A gets altered call dr_hook_watch('a(:)',a,LDABORT=.TRUE.,LDPRINT=.FALSE.,LDTRBK=.FALSE.) call sub1(a,n) deallocate(a) call dr_hook('drhook_ex2',1,zhook_handle) end program drhook_ex2 subroutine sub1(a,n) use yomhook, only : jphook, dr_hook implicit none integer(4), intent(in) :: n real(8), intent(inout) :: a(n) real(jphook) :: zhook_handle call dr_hook('sub1',0,zhook_handle) if (n > 0) call sub2(a(1)) call dr_hook('sub1',1,zhook_handle) end subroutine sub1 subroutine sub2(s) use yomhook, only : jphook, dr_hook implicit none real(8), intent(inout) :: s real(jphook) :: zhook_handle call dr_hook('sub2',0,zhook_handle) !s = 1/s ! divide by zero removed s = 1 ! a(1) has now been altered --> watch point should detect this call dr_hook('sub2',1,zhook_handle) end subroutine sub2 fiat-ecmwf-2.0.0/tests/drhook/CMakeLists.txt0000664000175000017500000000547115157200431021114 0ustar alastairalastairfind_package( CMath ) ecbuild_add_executable( TARGET drhook_ex1 SOURCES drhook_ex1.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_executable( TARGET drhook_ex2 SOURCES drhook_ex2.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_executable( TARGET drhook_ex3 SOURCES drhook_ex3.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_executable( TARGET drhook_ex4 SOURCES drhook_ex4.c LIBS ${fiatlib} ${CMATH_LIBRARIES} LINKER_LANGUAGE C NOINSTALL ) if( CMAKE_C_COMPILER_ID MATCHES "PGI|NVHPC" ) target_compile_options( drhook_ex4 PUBLIC -Ktrap=fp ) endif() ecbuild_add_executable( TARGET drhook_ex5 SOURCES drhook_ex5.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) set( FPE_TRAPPING_SUPPORTED 1 ) if( APPLE ) set( FPE_TRAPPING_SUPPORTED 0 ) endif() # Test floating point trapping ecbuild_add_test( TARGET fiat_test_drhook_ex1 COMMAND drhook_ex1 ENVIRONMENT DR_HOOK=1 DR_HOOK_TRAPFPE=1 DR_HOOK_ASSERT_MPI_INITIALIZED=0 DR_HOOK_OPT=NOPROPAGATE_SIGNALS ) if( FPE_TRAPPING_SUPPORTED ) set_tests_properties( fiat_test_drhook_ex1 PROPERTIES WILL_FAIL TRUE RESOURCE_LOCK drhook_lockfile ) endif() # Test watchpoint point trapping ecbuild_add_test( TARGET fiat_test_drhook_ex2 COMMAND drhook_ex2 ENVIRONMENT DR_HOOK=1 DR_HOOK_ASSERT_MPI_INITIALIZED=0 DR_HOOK_OPT=NOPROPAGATE_SIGNALS ) set_tests_properties( fiat_test_drhook_ex2 PROPERTIES WILL_FAIL TRUE RESOURCE_LOCK drhook_lockfile ) # Play with profiling options ecbuild_add_test( TARGET fiat_test_drhook_ex3 COMMAND drhook_ex3 ENVIRONMENT DR_HOOK=1 DR_HOOK_ASSERT_MPI_INITIALIZED=0 ) # Test floating point trapping from C program ecbuild_add_test( TARGET fiat_test_drhook_ex4 COMMAND drhook_ex4 ENVIRONMENT DR_HOOK=1 SIGFPE=1 DR_HOOK_ASSERT_MPI_INITIALIZED=0 DR_HOOK_OPT=NOPROPAGATE_SIGNALS ) if( FPE_TRAPPING_SUPPORTED ) set_tests_properties( fiat_test_drhook_ex4 PROPERTIES WILL_FAIL TRUE RESOURCE_LOCK drhook_lockfile ) endif() # Play MPI and dr_hook together ecbuild_add_test( TARGET fiat_test_drhook_ex5 COMMAND drhook_ex5 MPI 2 ENVIRONMENT DR_HOOK=1 DR_HOOK_SILENT=1 CONDITION HAVE_MPI ) # TODO: # Better parse output to see if it matches. add_subdirectory(drhook_core) # ------------------------------------------------------------------------------ # External Library Tests # ------------------------------------------------------------------------------ # NVTX if (HAVE_DR_HOOK_NVTX) add_subdirectory(drhook_nvtx) endif () # ROCTX if (HAVE_DR_HOOK_ROCTX) add_subdirectory(drhook_roctx) endif () # PAPI if (HAVE_DR_HOOK_PAPI) add_subdirectory(drhook_papi) endif () fiat-ecmwf-2.0.0/tests/test_install/0000775000175000017500000000000015157200431017564 5ustar alastairalastairfiat-ecmwf-2.0.0/tests/test_install/main.F900000664000175000017500000000136415157200431020774 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! program main ! From library fiat use yomhook ! assert found use mpl_module ! assert found ! From library parkind_(dp|sp) use parkind1, only: JPRB, JPIA ! assert found implicit none write(0,*) "JPRB =",JPRB ! depending on link with parkind_sp or parkind_dp this will print 4 or 8 write(0,*) "JPIA =",JPIA ! depending system this will print 4 or 8 end programfiat-ecmwf-2.0.0/tests/test_install/CMakeLists.txt0000664000175000017500000000220415157200431022322 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. cmake_minimum_required( VERSION 3.12 FATAL_ERROR ) find_package( ecbuild 3.3 REQUIRED ) project( fiat_test_install VERSION 0.0.0 LANGUAGES Fortran ) find_package( fiat REQUIRED ) find_package( MPI REQUIRED ) message("fiat_HAVE_MPL_F08: ${fiat_HAVE_MPL_F08}") if(TARGET fiat) set( fiatlib fiat) elseif(TARGET fiat-static) set( fiatlib fiat-static) else() message("Neither fiat nor fiat-static is exported by fiat build!") endif() if( TARGET parkind_dp ) ecbuild_add_executable( TARGET main_dp SOURCES main.F90 LIBS ${fiatlib} parkind_dp ) endif() if( TARGET parkind_sp ) ecbuild_add_executable( TARGET main_sp SOURCES main.F90 LIBS ${fiatlib} parkind_sp ) endif() fiat-ecmwf-2.0.0/tests/gatherv.F900000664000175000017500000001414515157200431017004 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Simple Test program ! subroutine fail_impl(msg,line) use mpl_module, only : mpl_abort character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in gatherv.F90 @ line ",line," :" write(0,*) msg call mpl_abort() end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) subroutine work1(r) implicit none integer, intent(out) :: r real a(100000) call random_number(a) if (any(a < 0.0) ) then r =1 else r =0 endif end subroutine work1 program test_mpl_gatherv use ec_parkind, only : jpim, jprm, jprd use mpl_module, only: mpl_init, mpl_end, mpl_rank, linitmpi_via_mpl, mpl_gatherv, JP_NON_BLOCKING_STANDARD, mpl_wait implicit none integer(jpim) :: nprocs logical :: verbose = .false. integer(jpim), allocatable :: sbuf(:), rbuf(:), rcounts(:) integer(jpim) :: scounts real(jprm), allocatable :: sbufr(:), rbufr(:) real(jprd), allocatable :: sbufd(:), rbufd(:) character(len=6) :: sbufc character(len=6), allocatable :: rbufc(:) integer i,j,k, kroot character(len=256) msg call mpl_init(KPROCS=nprocs,ldinfo=verbose,ldenv=.true.) if( nprocs <= 1 ) FAIL("nprocs must be > 1") if( mpl_rank < 1 .or. mpl_rank > nprocs ) FAIL("mpl_rank must be >= 1 and <= nprocs") if( .not. linitmpi_via_mpl ) FAIL("linitmpi_via_mpl must be True") allocate(sbuf(mpl_rank),rbuf((nprocs*(nprocs+1))/2+nprocs),& sbufr(mpl_rank),rbufr((nprocs*(nprocs+1))/2+nprocs), & sbufd(mpl_rank),rbufd((nprocs*(nprocs+1))/2+nprocs),& rcounts(nprocs)) !allocate(character(len=mpl_rank) :: sbufc) allocate(rbufc(nprocs)) sbuf = mpl_rank sbufr = mpl_rank sbufd = mpl_rank do i=1,len(sbufc) sbufc(i:i) = char(ichar('a')+mod(mpl_rank-1,26)) !print*,sbufc(i:i), mpl_rank enddo scounts=mpl_rank do i=1,nprocs rcounts(i)=i enddo kroot=2 call do_gatherv("blocking") call do_gatherv("nonblocking") call mpl_end(ldmeminfo=verbose) ! Note that with mpi_serial meminfo will not be printed regardless of ldmeminfo contains subroutine do_gatherv(mode) implicit none character(len=*), intent(in) :: mode character(len=128) :: msg integer request_i, request_r, request_d, request_c, i, j, k, res integer rdispl(nprocs), rcounts_c(nprocs) select case(mode) case("blocking") call mpl_gatherv(sbuf,kroot,rbuf,rcounts) call mpl_gatherv(sbufr,kroot,rbufr,rcounts) rcounts_c=6 call mpl_gatherv(sbufc,kroot,rbufc,rcounts_c) if (mpl_rank == kroot) then call mpl_gatherv(sbufd,kroot,rbufd,rcounts) else call mpl_gatherv(sbufd,kroot) endif case("nonblocking") ! trying to get a random failure do j=1,1 if (mpl_rank == kroot ) then call mpl_gatherv(sbuf,kroot,rbuf,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_gatherv(sbufr,kroot,rbufr,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_gatherv(sbufd,kroot,rbufd,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) rcounts_c=6 ! call mpl_gatherv(sbufc,kroot,rbufc,rcounts_c, KMP_TYPE = JP_NON_BLOCKING_STANDARD,KREQUEST=request_c) else call mpl_gatherv(sbuf,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_gatherv(sbufr,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_gatherv(sbufd,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) call mpl_gatherv(sbufc,kroot, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_c) endif call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_r) call mpl_wait(request_d) call mpl_wait(request_i) call mpl_wait(request_c) enddo end select ! test values if (mpl_rank == kroot) then k=1 do i=1,nprocs if ( any(rbuf(k:k+i-1) /= i) ) then !write(0,*) 'send ', mpl_rank, scounts, sbuf !write(0,*) 'recv ', mpl_rank, rcounts, rdispl write(msg,*) trim(mode)//" int alltoall test test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr(k:k+i-1)) /= i) ) then write(msg,*) trim(mode)//" real alltoall test test failed on mpl_rank", mpl_rank, rbufr FAIL(msg) endif if ( any(nint(rbufd(k:k+i-1)) /= i) ) then write(msg,*) trim(mode)//" double alltoall test test failed on mpl_rank", mpl_rank, rbufd FAIL(msg) endif if ( rbufc(i)(1:1) /= char(ichar('a')+mod(i-1,26)) ) then write(msg,*) trim(mode)//" char alltoall test test failed on mpl_rank", mpl_rank, rbufc(i) FAIL(msg) endif k=k+i enddo endif ! test with displacement arguments ! leaving a space of 1 between each block select case(mode) case("nonblocking") rdispl(1)=0 rdispl(1)=1 do i=2,nprocs rdispl(i)=rdispl(i-1)+(i-1)+1 enddo rbuf = 0 call mpl_gatherv(sbuf, kroot, rbuf, rcounts, krecvdispl=rdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_i) if (mpl_rank == kroot) then !write(*,*) "rbuf", rbuf k=1 do i=1,nprocs if ( any(rbuf(k+1:k+1+i-1) /= i) .or. rbuf(k) /= 0 ) then write(msg,*) trim(mode)//" int alltoall test with displ args failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif k=k+i+1 enddo endif end select end subroutine do_gatherv end program test_mpl_gatherv fiat-ecmwf-2.0.0/tests/test_mpi_serial.F900000664000175000017500000000053615157200431020526 0ustar alastairalastairprogram hello USE SDL_MOD , ONLY : SDL_SRLABORT, SDL_TRACEBACK implicit none include "mpif.h" integer rank, ierr call MPI_Init(ierr) call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr) write(6,*) "My rank number is ", rank CALL SDL_TRACEBACK call MPI_Finalize(ierr) write(6,*) "Execution finished ", rank end fiat-ecmwf-2.0.0/tests/allgatherv.F900000664000175000017500000001360015157200431017470 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Simple Test program ! subroutine fail_impl(msg,line) use mpl_module, only : mpl_abort character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in allgatherv.F90 @ line ",line," :" write(0,*) msg call mpl_abort() end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) subroutine work1(r) implicit none integer, intent(out) :: r real a(100000) call random_number(a) if (any(a < 0.0) ) then r =1 else r =0 endif end subroutine work1 program test_mpl_allgatherv use ec_parkind, only : jpim, jprm, jprd use mpl_module, only: mpl_init, mpl_end, mpl_rank, linitmpi_via_mpl, mpl_allgatherv, JP_NON_BLOCKING_STANDARD, mpl_wait implicit none integer(jpim) :: nprocs logical :: verbose = .false. character(len=256) msg call mpl_init(KPROCS=nprocs,ldinfo=verbose,ldenv=.true.) if( nprocs <= 1 ) FAIL("nprocs must be > 1") if( mpl_rank < 1 .or. mpl_rank > nprocs ) FAIL("mpl_rank must be >= 1 and <= nprocs") if( .not. linitmpi_via_mpl ) FAIL("linitmpi_via_mpl must be True") call do_allgatherv("blocking") call do_allgatherv("nonblocking") call mpl_end(ldmeminfo=verbose) ! Note that with mpi_serial meminfo will not be printed regardless of ldmeminfo contains subroutine do_allgatherv(mode) use ec_parkind, only : jpim, jprm, jprd implicit none character(len=*), intent(in) :: mode integer(jpim), allocatable :: sbuf(:), rbuf(:), rcounts(:) integer(jpim) :: scounts real(jprm), allocatable :: sbufr(:), rbufr(:) real(jprd), allocatable :: sbufd(:), rbufd(:) character(len=256) :: msg integer request_i, request_r, request_d, i, j, k, res integer rdispl(nprocs) allocate(sbuf(mpl_rank),rbuf((nprocs*(nprocs+1))/2+nprocs),& sbufr(mpl_rank),rbufr((nprocs*(nprocs+1))/2+nprocs), & sbufd(mpl_rank),rbufd((nprocs*(nprocs+1))/2+nprocs),& rcounts(nprocs)) sbuf = mpl_rank sbufr = mpl_rank sbufd = mpl_rank scounts = mpl_rank rcounts = [ (i, i=1,nprocs) ] select case(mode) case("blocking") call mpl_allgatherv(sbuf,rbuf,rcounts) call mpl_allgatherv(sbufr,rbufr,rcounts) call mpl_allgatherv(sbufd,rbufd,rcounts) case("nonblocking") ! trying to get a random failure do j=1,1 call mpl_allgatherv(sbuf,rbuf,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_allgatherv(sbufr,rbufr,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_allgatherv(sbufd,rbufd,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_r) call mpl_wait(request_d) call mpl_wait(request_i) enddo end select ! test values k=1 do i=1,nprocs if ( any(rbuf(k:k+i-1) /= i) ) then !write(0,*) 'send ', mpl_rank, scounts, sbuf !write(0,*) 'recv ', mpl_rank, rcounts, rdispl write(msg,*) trim(mode)//" int allgatherv test test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr(k:k+i-1)) /= i) ) then write(msg,*) trim(mode)//" real allgatherv test test failed on mpl_rank", mpl_rank, rbufr FAIL(msg) endif if ( any(nint(rbufd(k:k+i-1)) /= i) ) then write(msg,*) trim(mode)//" double allgatherv test test failed on mpl_rank", mpl_rank, rbufd FAIL(msg) endif k=k+i enddo ! test with displacement arguments ! leaving a space of 1 between each block rdispl(1)=1 do i=2,nprocs rdispl(i)=rdispl(i-1)+(i-1)+1 enddo select case(mode) case("blocking") call mpl_allgatherv(sbuf,rbuf,rcounts, KRECVDISPL=rdispl) call mpl_allgatherv(sbufr,rbufr,rcounts, KRECVDISPL=rdispl) call mpl_allgatherv(sbufd,rbufd,rcounts, KRECVDISPL=rdispl) case("nonblocking") ! trying to get a random failure do j=1,1 call mpl_allgatherv(sbuf,rbuf,rcounts,KRECVDISPL=rdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_allgatherv(sbufr,rbufr,rcounts,KRECVDISPL=rdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_allgatherv(sbufd,rbufd,rcounts,KRECVDISPL=rdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_r) call mpl_wait(request_d) call mpl_wait(request_i) enddo end select ! test values k=2 do i=1,nprocs if ( any(rbuf(k:k+i-1) /= i) ) then !write(0,*) 'send ', mpl_rank, scounts, sbuf !write(0,*) 'recv ', mpl_rank, rcounts, rdispl write(msg,*) trim(mode)//" int allgatherv test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr(k:k+i-1)) /= i) ) then write(msg,*) trim(mode)//" real allgatherv test failed on mpl_rank", mpl_rank, rbufr FAIL(msg) endif if ( any(nint(rbufd(k:k+i-1)) /= i) ) then write(msg,*) trim(mode)//" double allgatherv test failed on mpl_rank", mpl_rank, rbufd FAIL(msg) endif k=k+i+1 enddo ! test for int_scalar do i=1,nprocs rcounts(i) = mod(i+1,2) enddo select case(mode) case("blocking") call mpl_allgatherv(mpl_rank,rbuf(1:nprocs)) ! the simplest no correctness test just interface functionality call mpl_allgatherv(mpl_rank,rbuf,rcounts,ksendcount=mod(mpl_rank+1,2)) case("nonblocking") call mpl_allgatherv(mpl_rank,rbuf,rcounts,ksendcount=mod(mpl_rank+1,2), & KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_wait(request_i) end select do i=1,nprocs/2 if ( rbuf(i) /= 2*i) then write(msg,*) trim(mode)//" int_scalar allgatherv test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif enddo end subroutine do_allgatherv end program test_mpl_allgatherv fiat-ecmwf-2.0.0/tests/test_program_output.cmake0000664000175000017500000000224215157200431022207 0ustar alastairalastair# (C) Copyright 2019 ECMWF. # # This file is covered by the LICENSING file in the root of this project. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. function( run_command COMMAND ) set( COMMAND ${ARGV} ) string(REPLACE ";" " " PRINT_COMMAND "${COMMAND}" ) message( "${PRINT_COMMAND}" ) execute_process( COMMAND ${COMMAND} RESULT_VARIABLE res OUTPUT_VARIABLE stdout ERROR_VARIABLE stderr ) message("${stdout}") message("${stderr}") string(REGEX MATCH "${PASS_REGULAR_EXPRESSION}" stdout_match "${stdout}" ) string(REGEX MATCH "${PASS_REGULAR_EXPRESSION}" stderr_match "${stderr}" ) if( stdout_match OR stderr_match ) message( "Test succeeded: Regex [${PASS_REGULAR_EXPRESSION}] was found in program output") else() message( FATAL_ERROR "Test failed: Could not find regex [${PASS_REGULAR_EXPRESSION}] in program output") endif() endfunction() message( "Running test ${EXECUTABLE} ... ") run_command( ${LAUNCH} ${EXECUTABLE} ) message( "Running test ${EXECUTABLE} ... done") fiat-ecmwf-2.0.0/tests/test_drhook_counters.F900000664000175000017500000000577615157200431021625 0ustar alastairalastairprogram fiat_test_drhook_counters use oml_mod ,only : oml_max_threads use mpl_module, only : mpl_init, mpl_end, mpl_nproc, mpl_myrank use yomhook, only : LHOOK,DR_HOOK,JPHOOK,dr_hook_init,dr_hook_end use test_drhook_counters_stream_mod, only : stream_combinations use test_drhook_counters_gemm_mod, only : gemm_combinations use ec_env_mod, only : ec_setenv implicit none logical :: luse_mpi = .true. logical :: lsmall_problem_size = .false. integer :: myproc,nproc integer :: verbosity = 0 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE luse_mpi = detect_mpirun() lsmall_problem_size = detect_FIAT_UNIT_TEST() if (luse_mpi) then call mpl_init(ldinfo=(verbosity>=1)) nproc = mpl_nproc() myproc = mpl_myrank() else nproc = 1 myproc = 1 endif if (myproc.eq.1) write(6,*)'Starting Tasks=',nproc,'threads=',oml_max_threads() call ec_setenv("DR_HOOK", "1", overwrite=.true.) call ec_setenv("DR_HOOK_OPT", "COUNTERS", overwrite=.true.) call dr_hook_init() IF (LHOOK) CALL DR_HOOK('MAIN',0,ZHOOK_HANDLE) if (myproc.eq.1) write(6,*) "================================================= BENCHMARK STREAM START" if (lsmall_problem_size) then call stream_combinations(int(1024*32,kind=8)) else call stream_combinations() endif if (myproc.eq.1) write(6,*) "================================================= BENCHMARK STREAM END" if (myproc.eq.1) write(6,*) "================================================= BENCHMARK GEMM START" if (lsmall_problem_size) then call gemm_combinations(int(250,kind=8)) else call gemm_combinations() endif write(6,*) "================================================= BENCHMARK GEMM END" IF (LHOOK) CALL DR_HOOK('MAIN',1,ZHOOK_HANDLE) call dr_hook_end() if (luse_mpi) then call mpl_end(ldmeminfo=.false.) endif if (myproc.eq.1) write(6,*)'Completed' contains function detect_mpirun() result(lmpi_required) logical :: lmpi_required integer :: ilen integer, parameter :: nvars = 5 character(len=32), dimension(nvars) :: cmpirun_detect character(len=4) :: clenv_dr_hook_assert_mpi_initialized integer :: ivar lmpi_required = .false. #if defined(NOMPI) return #endif ! Environment variables that are set when mpirun, srun, aprun, ... are used cmpirun_detect(1) = 'OMPI_COMM_WORLD_SIZE' ! openmpi cmpirun_detect(2) = 'ALPS_APP_PE' ! cray pe cmpirun_detect(3) = 'PMI_SIZE' ! intel cmpirun_detect(4) = 'SLURM_NTASKS' ! slurm cmpirun_detect(5) = 'FIAT_USE_MPI' ! forced do ivar = 1, nvars call get_environment_variable(name=trim(cmpirun_detect(ivar)), length=ilen) if (ilen > 0) then lmpi_required = .true. exit ! break endif enddo end function function detect_FIAT_UNIT_TEST() result(lunit_test) logical :: lunit_test integer :: ilen lunit_test = .false. call get_environment_variable(name='FIAT_UNIT_TEST', length=ilen) if (ilen > 0) then lunit_test = .true. endif end function end program fiat-ecmwf-2.0.0/tests/test_abort_exception_handler.cc0000664000175000017500000000170315157200431023310 0ustar alastairalastair// (C) Copyright 2003- ECMWF. // // This software is licensed under the terms of the Apache Licence Version 2.0 // which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. // // In applying this licence, ECMWF does not waive the privileges and immunities // granted to it by virtue of its status as an intergovernmental organisation // nor does it submit to any jurisdiction. #include #include #include namespace my_namespace { class MyException : public std::exception { public: std::string msg_; MyException(const std::string& msg) : std::exception(), msg_(msg) {} virtual ~MyException() noexcept {} virtual const char* what() const noexcept { return msg_.c_str(); } }; void function_2 () { throw MyException("problem in function_2"); } void function_1 () { function_2(); } } // namespace my_namespace extern "C" { void my_namespace__function_1() { my_namespace::function_1(); } } fiat-ecmwf-2.0.0/tests/test_abort_exception_handler.F900000664000175000017500000000400715157200431023261 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! program abort_test use oml_mod use mpl_module use yomhook, only : lhook, dr_hook_init use fckit_module implicit none #include "abor1.intfb.h" interface subroutine my_namespace__function_1() bind(C) end subroutine end interface call test_init() if( fckit_mpi%rank() == fckit_mpi%size()-1 ) then call my_namespace__function_1() endif call test_end() contains subroutine test_init() use fckit_module, only : fckit_main, fckit_signal, fckit_exception use ec_env_mod, only : ec_setenv implicit none if( mpl() ) then call mpl_init(LDINFO=.TRUE.) endif call fckit_main%initialise() if( do_abor1() ) then call set_abor1_exception_handler() endif call ec_setenv("DR_HOOK","1",overwrite=.false.) call ec_setenv("DR_HOOK_SILENT","1",overwrite=.false.) call dr_hook_init() if (.not.lhook) then call fckit_signal%set_handler(fckit_signal%SIGTRAP()) call fckit_signal%set_handler(fckit_signal%SIGABRT()) endif end subroutine subroutine test_end() if( mpl() ) then call mpl_barrier() call mpl_end(LDMEMINFO=.FALSE.) endif end subroutine function mpl() result(lmpl) logical :: lmpl character(len=512) :: env CALL get_environment_variable('MPL',env) if( env == '0' ) then lmpl = .false. else lmpl = .true. endif end function function do_abor1() result(labor1) logical :: labor1 character(len=512) :: env = ' ' CALL get_environment_variable('ABOR1',env) if( env == '0' .or. len_trim(env) == 0 ) then labor1 = .false. else labor1 = .true. endif end function end program fiat-ecmwf-2.0.0/tests/test_checksum.c0000664000175000017500000000460715157200431020073 0ustar alastairalastair/* * (C) Copyright 2003- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include "fiat/ec_checksum.h" int err; void expect_equal(const uint16_t digest, const char* expected, int line_number) { char hex[5]; memset(hex, ' ', 4); snprintf(hex, 5, "%4x", digest); for(int i=0; i<4; ++i) { if(hex[i] == ' ') { hex[i] = '0'; } } if(strncmp(hex, expected, strlen(expected)) != 0) { fprintf(stderr,"ERROR: checksum '%s' different from expected '%s', in file %s, line %d\n",hex, expected, __FILE__, line_number); err = 1; } } #define EXPECT_EQUAL(digest, expected) expect_equal(digest, expected, __LINE__) int main(int argc, char* argv[]) { const int N = 100000; double* array = (double*)malloc(N*sizeof(double)); for( int i=0; i 1") if( mpl_rank < 1 .or. mpl_rank > nprocs ) FAIL("mpl_rank must be >= 1 and <= nprocs") if( .not. linitmpi_via_mpl ) FAIL("linitmpi_via_mpl must be True") allocate(sbuf((nprocs*(nprocs+1))/2),rbuf(nprocs*mpl_rank),& sbufr((nprocs*(nprocs+1))/2),rbufr(nprocs*mpl_rank), & sbufd((nprocs*(nprocs+1))/2),rbufd(nprocs*mpl_rank),& scounts(nprocs),rcounts(nprocs)) k=1 do i=1,nprocs do j=1,i sbuf (k) = mpl_rank sbufr(k) = mpl_rank sbufd(k) = mpl_rank k=k+1 enddo scounts(i)=i enddo rcounts(:)=mpl_rank call do_alltoallv_blocking() call do_alltoallv_nonblocking() call mpl_end(ldmeminfo=verbose) ! Note that with mpi_serial meminfo will not be printed regardless of ldmeminfo contains subroutine do_alltoallv_blocking implicit none character(len=256) :: msg integer request_i, request_r, request_d, i, j, k, res integer sdispl(nprocs), rdispl(nprocs), rqarray(3) if (mpl_rank == 1) write(0,*) "test nonblocking" call mpl_alltoallv(sbuf,scounts,rbuf,rcounts) call mpl_alltoallv(sbufr,scounts,rbufr,rcounts) call mpl_alltoallv(sbufd,scounts,rbufd,rcounts) k=1 do i=1,size(rbuf),mpl_rank if ( any(rbuf(i:i+mpl_rank-1) /= k) ) then write(msg,*) "blocking int alltoall test test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr(i:i+mpl_rank-1)) /= k) ) then write(msg,*) "blocking real alltoall test test failed on mpl_rank", mpl_rank, rbufr FAIL(msg) endif if ( any(nint(rbufd(i:i+mpl_rank-1)) /= k) ) then write(msg,*) "blocking double alltoall test test failed on mpl_rank", mpl_rank, rbufd FAIL(msg) endif k=k+1 enddo end subroutine do_alltoallv_blocking subroutine do_alltoallv_nonblocking() implicit none character(len=256) :: msg integer request_i, request_r, request_d, i, j, k, res integer sdispl(nprocs), rdispl(nprocs), rqarray(3) if (mpl_rank == 1) write(0,*) "test nonblocking" ! trying to get a random failure do j=1,1 call mpl_alltoallv(sbuf,scounts,rbuf,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call mpl_alltoallv(sbufr,scounts,rbufr,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_r) call mpl_alltoallv(sbufd,scounts,rbufd,rcounts, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_d) call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! !call mpl_wait(request_r) call mpl_wait(request_d) !call mpl_wait(request_i) rqarray = [request_i, request_r, request_d] call mpl_wait(rqarray(1:2)) enddo k = 1 do i=1,size(rbuf),mpl_rank if ( any(rbuf(i:i+mpl_rank-1) /= k) ) then write(msg,*) "nonblocking int alltoall test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufr(i:i+mpl_rank-1)) /= k) ) then write(msg,*) "nonblocking real alltoall test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif if ( any(nint(rbufd(i:i+mpl_rank-1)) /= k) ) then write(msg,*) "nonblocking double alltoall test failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif k = k+1 enddo ! test with displacement arguments sdispl(1)=0 rdispl(1)=0 do i=2,nprocs sdispl(i)=sdispl(i-1)+scounts(i-1) rdispl(i)=rdispl(i-1)+rcounts(i-1) enddo call mpl_alltoallv(sbuf, scounts, rbuf, rcounts, sdispl, rdispl, KMP_TYPE = JP_NON_BLOCKING_STANDARD, KREQUEST=request_i) call work1(res) if ( res > 0 ) write(0,*) "error in work1 non-blocking alltoallv" ! this should not happen ever !!! call mpl_wait(request_i) k=1 do i=1,nprocs,mpl_rank if ( any(rbuf(i:i+mpl_rank-1) /= k) ) then write(msg,*) "nonblocking int alltoall test with displ args failed on mpl_rank", mpl_rank, rbuf FAIL(msg) endif k=k+1 enddo end subroutine do_alltoallv_nonblocking end program test_mpl_alltoallv fiat-ecmwf-2.0.0/tests/test_drhook_no_output.cmake0000664000175000017500000000232715157200431022526 0ustar alastairalastair# (C) Copyright 2019 ECMWF. # # This file is covered by the LICENSING file in the root of this project. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. function( run_command COMMAND ) set( COMMAND ${ARGV} ) string(REPLACE ";" " " PRINT_COMMAND "${COMMAND}" ) message( "${PRINT_COMMAND}" ) execute_process( COMMAND ${COMMAND} RESULT_VARIABLE res OUTPUT_VARIABLE stdout ERROR_VARIABLE stderr ) if(res) set( error TRUE ) message("Test failed.") endif() if(stdout MATCHES "srun") set( stdout "" ) endif() if(stderr MATCHES "srun") set( stderr "" ) endif() if( stdout OR stderr ) set( error TRUE ) message("${stdout}") message("${stderr}") if( $ENV{FIAT_TEST_IGNORE_MPI_OUTPUT} ) set( error FALSE ) else() message("Test failed. Executable should have no output") endif() endif() if( error ) message(FATAL_ERROR "Test failed") endif() endfunction() message( "Running test ${EXECUTABLE} ... ") run_command( ${LAUNCH} ${EXECUTABLE} ) message( "Running test ${EXECUTABLE} ... done") fiat-ecmwf-2.0.0/tests/test_mpl_no_output.cmake0000664000175000017500000000241615157200431022027 0ustar alastairalastair# (C) Copyright 2019 ECMWF. # # This file is covered by the LICENSING file in the root of this project. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. function( run_command COMMAND ) set( COMMAND ${ARGV} ) string(REPLACE ";" " " PRINT_COMMAND "${COMMAND}" ) message( "${PRINT_COMMAND}" ) execute_process( COMMAND ${COMMAND} RESULT_VARIABLE res OUTPUT_VARIABLE stdout ERROR_VARIABLE stderr ) if(res) set( error TRUE ) message("Test failed. This could be because executable is not launched with correctly (aprun, srun, mpirun, ...)") endif() if( stdout OR stderr ) set( error TRUE ) message("${stdout}") message("${stderr}") if( $ENV{FIAT_TEST_IGNORE_MPI_OUTPUT} ) set( error FALSE ) else() message("Test failed. Executable should have no output. Set FIAT_TEST_IGNORE_MPI_OUTPUT=1 in environment if the output is not from MPL.") endif() endif() if( error ) message(FATAL_ERROR "Test failed.") endif() endfunction() message( "Running test ${EXECUTABLE} ... ") run_command( ${LAUNCH} ${EXECUTABLE} ) message( "Running test ${EXECUTABLE} ... done") fiat-ecmwf-2.0.0/tests/test_drhook_fortran.F900000664000175000017500000000741015157200431021421 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! program test_drhook use yomhook use oml_mod use mpl_module #ifdef WITH_FCKIT use fckit_module #endif implicit none real(jphook) :: zhook_handle integer :: nproc, myproc call test_init() if (lhook) call dr_hook('test_drhook',0,zhook_handle) call function_1() if (lhook) call dr_hook('test_drhook',1,zhook_handle) call test_end() contains subroutine function_3 implicit none #include "abor1.intfb.h" real(jphook) :: zhook_handle real(jphook) :: automatic_array(10,10) if (lhook) call dr_hook('function_3',0,zhook_handle) automatic_array = 2 if( do_abort() .and. oml_my_thread() == oml_max_threads() .and. ( myproc == nproc ) ) then call abor1fl("test_drhook_fortran.F90",__LINE__,"problem in function_3") endif if (lhook) call dr_hook('function_3',1,zhook_handle) end subroutine subroutine function_2 implicit none real(jphook) :: zhook_handle real(jphook) :: automatic_array(10,10) if (lhook) call dr_hook('function_2',0,zhook_handle) automatic_array = 1 !$OMP PARALLEL call function_3() !$OMP END PARALLEL call barrier() if (lhook) call dr_hook('function_2',1,zhook_handle) end subroutine subroutine function_1 implicit none real(jphook) :: zhook_handle real(jphook) :: automatic_array(10,10) automatic_array = 3 if (lhook) call dr_hook('function_1',0,zhook_handle) call function_2() if (lhook) call dr_hook('function_1',1,zhook_handle) end subroutine ! ----------------------------------------------------------------------------------------- ! Initialization and Finalization ! ----------------------------------------------------------------------------------------- subroutine test_init use ec_env_mod, only : ec_setenv if( mpl() ) then call mpl_init(ldinfo=.true.) nproc = mpl_numproc myproc = mpl_rank #ifdef WITH_FCKIT elseif( fckit() ) then call fckit_main%init() nproc = fckit_mpi%size() myproc = fckit_mpi%rank() + 1 #else else nproc = 1 myproc = 1 #endif endif call ec_setenv("DR_HOOK", "1", overwrite=.true.) call ec_setenv("DR_HOOK_OPT", "PROF",overwrite=.false.) call ec_setenv("DR_HOOK_SILENT", "1", overwrite=.false.) end subroutine subroutine test_end call dr_hook_end() if( mpl() ) then call mpl_end(ldmeminfo=.false.) endif end subroutine ! ----------------------------------------------------------------------------------------- ! Utility functions, checking environment variables etc ! ----------------------------------------------------------------------------------------- function do_abort() result(labort) logical :: labort character(len=512) :: env call get_environment_variable("ABORT",env) if( env == '0' ) then labort = .false. else labort = .true. endif end function function mpl() result(lmpl) logical :: lmpl character(len=512) :: env call get_environment_variable("MPL",env) if( env == '0' ) then lmpl = .false. else lmpl = .true. endif end function function fckit() result(lfckit) logical :: lfckit character(len=512) :: env call get_environment_variable("FCKIT",env) if( env == '0' ) then lfckit = .false. else lfckit = .true. endif end function subroutine barrier() if( mpl() ) then call mpl_barrier() #ifdef WITH_FCKIT elseif( fckit() ) then call fckit_mpi%barrier() #endif endif end subroutine ! ----------------------------------------------------------------------------------------- end program fiat-ecmwf-2.0.0/tests/test_byteswap.F900000664000175000017500000002113215157200431020233 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Simple Test program ! subroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_byteswap.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) program byteswap_test use byteswap_mod use, intrinsic :: iso_c_binding implicit none call test_convert_to_big_endian_int32() call test_convert_to_big_endian_int64() call test_convert_to_big_endian_real32() call test_convert_to_big_endian_real64() call test_byteswap_int32() call test_byteswap_int64() call test_byteswap_real32() call test_byteswap_real64() write(0,'(A)') "SUCCESS" CONTAINS subroutine test_convert_to_big_endian_int32() integer :: i integer(c_int32_t) :: buffer(3), buffer_BE(3) character(len=8) :: hex(3), hex_BE(3) write(0,'(A)') "test_convert_to_big_endian_int32" buffer = [12345678,23456789,34567890] call convert_to_big_endian(buffer_BE, buffer) !call iswap(buffer_BE, buffer, 4, 3) if (is_little_endian()) then do i=1,3 write(hex(i),'(Z8.8)') transfer(buffer(i),0_c_int32_t) write(hex_BE(i),'(Z8.8)') transfer(buffer_BE(i),0_c_int32_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["4E61BC00","15EC6501","D2760F02"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_convert_to_big_endian_int64() integer :: i integer(c_int64_t) :: buffer(3), buffer_BE(3) character(len=16) :: hex(3), hex_BE(3) write(0,'(A)') "test_convert_to_big_endian_int64" buffer = [123456789012345678_c_int64_t,& 234567890123456789_c_int64_t,& 345678901234567890_c_int64_t] call convert_to_big_endian(buffer_BE, buffer) !call iswap(buffer_BE, buffer, 8, 3) if (is_little_endian()) then do i=1,3 write(hex(i),'(Z16.16)') transfer(buffer(i),0_c_int64_t) write(hex_BE(i),'(Z16.16)') transfer(buffer_BE(i),0_c_int64_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["4EF330A64B9BB601","158185D6405A4103","D20A6F122119CC04"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_convert_to_big_endian_real32() integer :: i real(c_float) :: buffer(3), buffer_BE(3) character(len=8) :: hex(3), hex_BE(3) write(0,'(A)') "test_convert_to_big_endian_real32" buffer = [1.234_c_float,2.345_c_float,3.456_c_float] call convert_to_big_endian(buffer_BE, buffer) !call iswap(buffer_BE, buffer, 4, 3) if (is_little_endian()) then do i=1,3 write(hex(i),'(Z8.8)') transfer(buffer(i),0_c_int32_t) write(hex_BE(i),'(Z8.8)') transfer(buffer_BE(i),0_c_int32_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["B6F39D3F","7B141640","1B2F5D40"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_convert_to_big_endian_real64() integer :: i real(c_double) :: buffer(3), buffer_BE(3) character(len=16) :: hex(3), hex_BE(3) write(0,'(A)') "test_convert_to_big_endian_real64" buffer = [1.234567890123_c_double, & 2.345678901234_c_double, & 3.456789012345_c_double] call convert_to_big_endian(buffer_BE, buffer) !call iswap(buffer_BE, buffer, 8, 3) if (is_little_endian()) then do i=1,3 write(hex(i),'(Z16.16)') transfer(buffer(i),0_c_int64_t) write(hex_BE(i),'(Z16.16)') transfer(buffer_BE(i),0_c_int64_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["F2518C42CAC0F33F","EABCBD4CF3C30240","238D69FF80A70B40"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_byteswap_int32() integer :: i integer(c_int32_t) :: buffer(3), buffer_BE(3) character(len=8) :: hex(3), hex_BE(3) write(0,'(A)') "test_byteswap_int32" buffer = [12345678,23456789,34567890] if (is_little_endian()) then call byteswap(buffer_BE, buffer) !call jswap(buffer_BE, buffer, 4, 3) else buffer_BE = buffer endif if (is_little_endian()) then do i=1,3 write(hex(i),'(Z8.8)') transfer(buffer(i),0_c_int32_t) write(hex_BE(i),'(Z8.8)') transfer(buffer_BE(i),0_c_int32_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["4E61BC00","15EC6501","D2760F02"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_byteswap_int64() integer :: i integer(c_int64_t) :: buffer(3), buffer_BE(3) character(len=16) :: hex(3), hex_BE(3) write(0,'(A)') "test_byteswap_int64" buffer = [123456789012345678_c_int64_t,& 234567890123456789_c_int64_t,& 345678901234567890_c_int64_t] if (is_little_endian()) then call byteswap(buffer_BE, buffer) !call jswap(buffer_BE, buffer, 8, 3) else buffer_BE = buffer endif if (is_little_endian()) then do i=1,3 write(hex(i),'(Z16.16)') transfer(buffer(i),0_c_int64_t) write(hex_BE(i),'(Z16.16)') transfer(buffer_BE(i),0_c_int64_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["4EF330A64B9BB601","158185D6405A4103","D20A6F122119CC04"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_byteswap_real32() integer :: i real(c_float) :: buffer(3), buffer_BE(3) character(len=8) :: hex(3), hex_BE(3) write(0,'(A)') "test_byteswap_real32" buffer = [1.234_c_float,2.345_c_float,3.456_c_float] if (is_little_endian()) then call byteswap(buffer_BE, buffer) !call jswap(buffer_BE, buffer, 4, 3) else buffer_BE = buffer endif if (is_little_endian()) then do i=1,3 write(hex(i),'(Z8.8)') transfer(buffer(i),0_c_int32_t) write(hex_BE(i),'(Z8.8)') transfer(buffer_BE(i),0_c_int32_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["B6F39D3F","7B141640","1B2F5D40"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine subroutine test_byteswap_real64() integer :: i real(c_double) :: buffer(3), buffer_BE(3) character(len=16) :: hex(3), hex_BE(3) write(0,'(A)') "test_byteswap_real64" buffer = [1.234567890123_c_double, & 2.345678901234_c_double, & 3.456789012345_c_double] if (is_little_endian()) then call byteswap(buffer_BE, buffer) !call jswap(buffer_BE, buffer, 8, 3) else buffer_BE = buffer endif if (is_little_endian()) then do i=1,3 write(hex(i),'(Z16.16)') transfer(buffer(i),0_c_int64_t) write(hex_BE(i),'(Z16.16)') transfer(buffer_BE(i),0_c_int64_t) write(0,*) " ", hex(i), " --> " , hex_BE(i) enddo if (any(hex_BE /= ["F2518C42CAC0F33F","EABCBD4CF3C30240","238D69FF80A70B40"])) then FAIL("conversion to big_endian failed") endif else if (any(buffer /= buffer_BE) ) then FAIL("buffer_BE should be copy of buffer on big_endian architecture") endif endif end subroutine end program fiat-ecmwf-2.0.0/tests/test_abor1.F900000664000175000017500000000426215157200431017406 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! This program aborts from an OpenMP parallel region ! It can be called within a MPI-parallel context when "MPL=1" is set in the environment ! To enable DR_HOOK, set "DR_HOOK=1" in environment program test_abor1 use oml_mod use mpl_module use yomhook implicit none #include "abor1.intfb.h" call test_init() if( MPL_RANK <= 1 ) write(0,'(A,I0)') "OML_MAX_THREADS = ", OML_MAX_THREADS() !$OMP PARALLEL if( OML_MY_THREAD() == OML_GET_NUM_THREADS() .AND. (MPL_RANK == MPL_NUMPROC .OR. MPL_NUMPROC < 0)) then if( do_abort() ) call abor1fl("test_abort.F90",__LINE__,"aborting from OpenMP parallel region") endif !$OMP END PARALLEL call test_end() contains subroutine test_init() use ec_env_mod, only : ec_setenv implicit none ! Only enables MPL when environment MPL=1 if( mpl() ) then call mpl_init(LDINFO=.FALSE.) endif ! Only enables DR_HOOK when environment DR_HOOK=1 call ec_setenv("DR_HOOK_SILENT","1",overwrite=.false.) call dr_hook_init() end subroutine subroutine test_end() ! Should not reach here unless "ABORT=0" in environment if( mpl() ) then call mpl_barrier() call mpl_end(LDMEMINFO=.FALSE.) endif end subroutine function do_abort() result(labort) logical :: labort character(len=512) :: env call get_environment_variable("ABORT",env) if( env == '0' ) then labort = .false. else labort = .true. endif end function function mpl() result(lmpl) logical :: lmpl character(len=512) :: env call get_environment_variable("MPL",env) if( env == '1' ) then lmpl = .true. else lmpl = .false. endif end function end program fiat-ecmwf-2.0.0/tests/displs_container.F900000664000175000017500000000462315157200431020704 0ustar alastairalastairsubroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_mpl.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) program main use mpl_displs_container_mod implicit none integer, pointer :: send_pt(:), recv_pt(:) integer, allocatable :: send(:), recv(:) integer i, req, r1, r2, nproc integer,allocatable :: aux(:) logical copy type(list_manager), pointer :: list => null() list => yddispls_list ! keep it simple nproc = 1 allocate(send(nproc),recv(nproc)) req = 1 call list%append(req,nproc,send_pt,recv_pt) !write(0,*) associated(send_pt), associated(recv_pt),list%head%get_nproc(),list%head%get_req() send_pt = 1 recv_pt = 1 req = 2 call list%append(req, nproc,send_pt, recv_pt) send_pt = 2 recv_pt = 2 send = list%head%get_send() recv = list%head%get_recv() if ( list%list_size /= 2 .or. list%head%req /= 2 & .or. send(1) /= 2 .or. recv(1) /= 2) FAIL("append 2 nodes failed") !call list%print_list() !write(*,*) '+++++++++++++++++++++++++++++++' call list%remove_first() send = list%head%get_send() recv = list%head%get_recv() if ( list%list_size /= 1 .or. list%head%req /= 1 & .or. send(1) /=1 .or. recv(1) /=1) FAIL("head remove failed") req = 4 call list%append(req) call list%remove_req(2) if ( list%list_size /= 2 .or. list%head%get_req() /= 4 ) FAIL("try to remove non-existent request failed") call list%remove_req(1) if ( list%list_size /= 1 .or. list%head%get_req() /= 4 ) FAIL("try to remove inner node failed") req = 5 call list%append(knproc=nproc,ksend_pt=send_pt) call list%append(krecv_pt=recv_pt,no_new_node=.true.) call list%append(kreq=req,no_new_node=.true.) if ( list%list_size /= 2 .or. list%head%get_req() /=5) FAIL("try one update in two steps failed") call list%clear_list() if ( associated(list%head) .or. list%list_size /=0 ) FAIL("clear list failed") ! remove two consecutive nodes do i=1,10 call list%append(i) enddo r1=7 r2=8 call list%remove_req(r2) call list%remove_req(r1) if (list%list_size /= 8) FAIL("remove two consecutive nodes failed 1") allocate(aux(10)) do i = 10,1,-1 if(i == r1 .or. i == r2) cycle aux(i) = list%head%get_req() call list%remove_first() enddo if (associated(list%head)) FAIL("remove two consecutive nodes failed 2") do i=1,10 if (i == r1 .or. i == r2) cycle if (aux(i) /= i) FAIL("remove two consecutive nodes failed 3") enddo end program main fiat-ecmwf-2.0.0/tests/test_checksum.F900000664000175000017500000005730115157200431020206 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Test program to test ec_checksum_mod module fiat_test_fletcher16_type_mod ! A helper module to initialise arrays used in the tests interface create_array module procedure :: create_array_real32_r1 module procedure :: create_array_real32_r2 module procedure :: create_array_real32_r3 module procedure :: create_array_real32_r4 module procedure :: create_array_real64_r1 module procedure :: create_array_real64_r2 module procedure :: create_array_real64_r3 module procedure :: create_array_real64_r4 module procedure :: create_array_int32_r1 module procedure :: create_array_int32_r2 module procedure :: create_array_int32_r3 module procedure :: create_array_int32_r4 module procedure :: create_array_int64_r1 module procedure :: create_array_int64_r2 module procedure :: create_array_int64_r3 module procedure :: create_array_int64_r4 end interface interface create_split_arrays module procedure :: create_split_arrays_real32_r1 module procedure :: create_split_arrays_real64_r1 end interface contains subroutine create_array_real32_r1(array) use, intrinsic :: iso_c_binding real(c_float), allocatable :: array(:) integer :: i integer, parameter :: N = 100000 allocate(array(N)) do i=1,N array(i) = i enddo end subroutine subroutine create_array_real32_r2(array) use, intrinsic :: iso_c_binding real(c_float), allocatable :: array(:,:) integer :: i, j integer, parameter :: N = 100000 integer, parameter :: Ni = N/200 integer, parameter :: Nj = N/Ni allocate(array(Ni,Nj)) do j=1,Nj do i=1,Ni array(i,j) = i + (j-1) * Ni enddo enddo end subroutine subroutine create_array_real32_r3(array) use, intrinsic :: iso_c_binding real(c_float), allocatable :: array(:,:,:) integer :: i, j, k integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 500 allocate(array(Ni,Nj,Nk)) do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k) = i + (j-1) * Ni + (k-1) * (Ni * Nj) enddo enddo enddo end subroutine subroutine create_array_real32_r4(array) use, intrinsic :: iso_c_binding real(c_float), allocatable :: array(:,:,:,:) integer :: i, j, k, l integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 10 integer, parameter :: Nl = 50 allocate(array(Ni,Nj,Nk,Nl)) do l=1,Nl do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k,l) = i + (j-1) * Ni + (k-1) * (Ni * Nj) + (l-1) * (Ni * Nj * Nk) enddo enddo enddo enddo end subroutine subroutine create_array_real64_r1(array) use, intrinsic :: iso_c_binding real(c_double), allocatable :: array(:) integer :: i integer, parameter :: N = 100000 allocate(array(N)) do i=1,N array(i) = i enddo end subroutine subroutine create_array_real64_r2(array) use, intrinsic :: iso_c_binding real(c_double), allocatable :: array(:,:) integer :: i, j integer, parameter :: N = 100000 integer, parameter :: Ni = N/200 integer, parameter :: Nj = N/Ni allocate(array(Ni,Nj)) do j=1,Nj do i=1,Ni array(i,j) = i + (j-1) * Ni enddo enddo end subroutine subroutine create_array_real64_r3(array) use, intrinsic :: iso_c_binding real(c_double), allocatable :: array(:,:,:) integer :: i, j, k integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 500 allocate(array(Ni,Nj,Nk)) do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k) = i + (j-1) * Ni + (k-1) * (Ni * Nj) enddo enddo enddo end subroutine subroutine create_array_real64_r4(array) use, intrinsic :: iso_c_binding real(c_double), allocatable :: array(:,:,:,:) integer :: i, j, k, l integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 10 integer, parameter :: Nl = 50 allocate(array(Ni,Nj,Nk,Nl)) do l=1,Nl do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k,l) = i + (j-1) * Ni + (k-1) * (Ni * Nj) + (l-1) * (Ni * Nj * Nk) enddo enddo enddo enddo end subroutine subroutine create_array_int32_r1(array) use, intrinsic :: iso_c_binding integer(c_int32_t), allocatable :: array(:) integer :: i integer, parameter :: N = 100000 allocate(array(N)) do i=1,N array(i) = i enddo end subroutine subroutine create_array_int32_r2(array) use, intrinsic :: iso_c_binding integer(c_int32_t), allocatable :: array(:,:) integer :: i, j integer, parameter :: N = 100000 integer, parameter :: Ni = N/200 integer, parameter :: Nj = N/Ni allocate(array(Ni,Nj)) do j=1,Nj do i=1,Ni array(i,j) = i + (j-1) * Ni enddo enddo end subroutine subroutine create_array_int32_r3(array) use, intrinsic :: iso_c_binding integer(c_int32_t), allocatable :: array(:,:,:) integer :: i, j, k integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 500 allocate(array(Ni,Nj,Nk)) do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k) = i + (j-1) * Ni + (k-1) * (Ni * Nj) enddo enddo enddo end subroutine subroutine create_array_int32_r4(array) use, intrinsic :: iso_c_binding integer(c_int32_t), allocatable :: array(:,:,:,:) integer :: i, j, k, l integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 10 integer, parameter :: Nl = 50 allocate(array(Ni,Nj,Nk,Nl)) do l=1,Nl do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k,l) = i + (j-1) * Ni + (k-1) * (Ni * Nj) + (l-1) * (Ni * Nj * Nk) enddo enddo enddo enddo end subroutine subroutine create_array_int64_r1(array) use, intrinsic :: iso_c_binding integer(c_int64_t), allocatable :: array(:) integer :: i integer, parameter :: N = 100000 allocate(array(N)) do i=1,N array(i) = i enddo end subroutine subroutine create_array_int64_r2(array) use, intrinsic :: iso_c_binding integer(c_int64_t), allocatable :: array(:,:) integer :: i, j integer, parameter :: N = 100000 integer, parameter :: Ni = N/200 integer, parameter :: Nj = N/Ni allocate(array(Ni,Nj)) do j=1,Nj do i=1,Ni array(i,j) = i + (j-1) * Ni enddo enddo end subroutine subroutine create_array_int64_r3(array) use, intrinsic :: iso_c_binding integer(c_int64_t), allocatable :: array(:,:,:) integer :: i, j, k integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 500 allocate(array(Ni,Nj,Nk)) do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k) = i + (j-1) * Ni + (k-1) * (Ni * Nj) enddo enddo enddo end subroutine subroutine create_array_int64_r4(array) use, intrinsic :: iso_c_binding integer(c_int64_t), allocatable :: array(:,:,:,:) integer :: i, j, k, l integer, parameter :: Ni = 25 integer, parameter :: Nj = 8 integer, parameter :: Nk = 10 integer, parameter :: Nl = 50 allocate(array(Ni,Nj,Nk,Nl)) do l=1,Nl do k=1,Nk do j=1,Nj do i=1,Ni array(i,j,k,l) = i + (j-1) * Ni + (k-1) * (Ni * Nj) + (l-1) * (Ni * Nj * Nk) enddo enddo enddo enddo end subroutine subroutine create_split_arrays_real32_r1(array1, array2) use, intrinsic :: iso_c_binding real(c_float), allocatable :: array1(:), array2(:) integer :: i integer, parameter :: N = 100000 integer :: N1, N2 N1 = N / 3 N2 = N - N1 allocate(array1(N1)) allocate(array2(N2)) do i=1,N1 array1(i) = i enddo do i=1,N2 array2(i) = N1 + i enddo end subroutine subroutine create_split_arrays_real64_r1(array1, array2) use, intrinsic :: iso_c_binding real(c_double), allocatable :: array1(:), array2(:) integer :: i integer, parameter :: N = 100000 integer :: N1, N2 N1 = N / 3 N2 = N - N1 allocate(array1(N1)) allocate(array2(N2)) do i=1,N1 array1(i) = i enddo do i=1,N2 array2(i) = N1 + i enddo end subroutine end module fiat_test_fletcher16_type_mod subroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_byteswap.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) program test_checksum use ec_checksum_mod use fiat_test_fletcher16_type_mod use, intrinsic :: iso_c_binding implicit none call test_fletcher16_type_real32_r1() call test_fletcher16_type_real32_r2() call test_fletcher16_type_real32_r3() call test_fletcher16_type_real32_r4() call test_fletcher16_type_real64_r1() call test_fletcher16_type_real64_r2() call test_fletcher16_type_real64_r3() call test_fletcher16_type_real64_r4() call test_fletcher16_type_int32_r1() call test_fletcher16_type_int32_r2() call test_fletcher16_type_int32_r3() call test_fletcher16_type_int32_r4() call test_fletcher16_type_int64_r1() call test_fletcher16_type_int64_r2() call test_fletcher16_type_int64_r3() call test_fletcher16_type_int64_r4() call test_fletcher16_type_split_real32_r1() call test_fletcher16_type_split_real64_r1() call test_fletcher16_real32_r1() call test_fletcher16_real32_r2() call test_fletcher16_real32_r3() call test_fletcher16_real32_r4() call test_fletcher16_real64_r1() call test_fletcher16_real64_r2() call test_fletcher16_real64_r3() call test_fletcher16_real64_r4() call test_fletcher16_int32_r1() call test_fletcher16_int32_r2() call test_fletcher16_int32_r3() call test_fletcher16_int32_r4() call test_fletcher16_int64_r1() call test_fletcher16_int64_r2() call test_fletcher16_int64_r3() call test_fletcher16_int64_r4() write(0,'(A)') "SUCCESS" CONTAINS subroutine test_fletcher16_type_real32_r1() real(c_float), allocatable :: array(:) type(fletcher16_type) :: checksum character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_type_real32_r1" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real32_r2() real(c_float), allocatable :: array(:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_type_real32_r2" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real32_r3() real(c_float), allocatable :: array(:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_type_real32_r3" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real32_r4() real(c_float), allocatable :: array(:,:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_type_real32_r4" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real64_r1() real(c_double), allocatable :: array(:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_type_real64_r1" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real64_r2() real(c_double), allocatable :: array(:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_type_real64_r2" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real64_r3() real(c_double), allocatable :: array(:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_type_real64_r2" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_real64_r4() real(c_double), allocatable :: array(:,:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_type_real64_r4" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int32_r1() integer(c_int32_t), allocatable :: array(:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_type_int32_r1" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int32_r2() integer(c_int32_t), allocatable :: array(:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_type_int32_r2" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int32_r3() integer(c_int32_t), allocatable :: array(:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_type_int32_r3" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int32_r4() integer(c_int32_t), allocatable :: array(:,:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_type_int32_r4" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int64_r1() integer(c_int64_t), allocatable :: array(:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_type_int64_r1" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int64_r2() integer(c_int64_t), allocatable :: array(:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_type_int64_r2" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int64_r3() integer(c_int64_t), allocatable :: array(:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_type_int64_r2" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_int64_r4() integer(c_int64_t), allocatable :: array(:,:,:,:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_type_int64_r4" call create_array(array) call checksum%update(array) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_split_real32_r1() real(c_float), allocatable :: array1(:), array2(:) type(fletcher16_type) :: checksum character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_type_split_real32_r1" call create_split_arrays(array1, array2) call checksum%update(array1) call checksum%update(array2) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_type_split_real64_r1() real(c_double), allocatable :: array1(:), array2(:) type(fletcher16_type) :: checksum character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_type_split_real64_r1" call create_split_arrays(array1, array2) call checksum%update(array1) call checksum%update(array2) if (checksum%digest_hex() /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//checksum%digest_hex()) endif end subroutine subroutine test_fletcher16_real32_r1() real(c_float), allocatable :: array(:) character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_real32_r1" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real32_r2() real(c_float), allocatable :: array(:,:) character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_real32_r2" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real32_r3() real(c_float), allocatable :: array(:,:,:) character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_real32_r3" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real32_r4() real(c_float), allocatable :: array(:,:,:,:) character(len=4) :: expected = '44c2' write(0,'(A)') "test_fletcher16_real32_r4" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real64_r1() real(c_double), allocatable :: array(:) character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_real64_r1" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real64_r2() real(c_double), allocatable :: array(:,:) character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_real64_r2" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real64_r3() real(c_double), allocatable :: array(:,:,:) character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_real64_r3" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_real64_r4() real(c_double), allocatable :: array(:,:,:,:) character(len=4) :: expected = 'ca21' write(0,'(A)') "test_fletcher16_real64_r4" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int32_r1() integer(c_int32_t), allocatable :: array(:) character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_int32_r1" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int32_r2() integer(c_int32_t), allocatable :: array(:,:) character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_int32_r2" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int32_r3() integer(c_int32_t), allocatable :: array(:,:,:) character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_int32_r3" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int32_r4() integer(c_int32_t), allocatable :: array(:,:,:,:) character(len=4) :: expected = 'e137' write(0,'(A)') "test_fletcher16_int32_r4" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int64_r1() integer(c_int64_t), allocatable :: array(:) character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_int64_r1" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int64_r2() integer(c_int64_t), allocatable :: array(:,:) character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_int64_r2" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int64_r3() integer(c_int64_t), allocatable :: array(:,:,:) character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_int64_r3" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine subroutine test_fletcher16_int64_r4() integer(c_int64_t), allocatable :: array(:,:,:,:) character(len=4) :: expected = 'a037' write(0,'(A)') "test_fletcher16_int64_r4" call create_array(array) if (fletcher16_hex(array) /= expected) then FAIL('checksum failed. Expected: '//expected//' , Computed: '//fletcher16_hex(array)) endif end subroutine end program fiat-ecmwf-2.0.0/tests/test_mpl_no_output.F900000664000175000017500000000224415157200431021304 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Simple Test program ! subroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_mpl.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) program test_mpl use ec_parkind, only : jpim use mpl_module, only: mpl_init, mpl_end, mpl_rank, linitmpi_via_mpl implicit none integer(jpim) :: nprocs logical :: verbose = .false. call mpl_init(KPROCS=nprocs,ldinfo=verbose,ldenv=.true.) if( nprocs == 0 ) FAIL("nprocs must be > 0") if( mpl_rank == 0 ) FAIL("mpl_rank must be >= 1") if( .not. linitmpi_via_mpl ) FAIL("linitmpi_via_mpl must be True") call mpl_end(ldmeminfo=verbose) ! Note that with mpi_serial meminfo will not be printed regardless of ldmeminfo end program fiat-ecmwf-2.0.0/tests/test_drhook_abort.c0000664000175000017500000000506415157200431020744 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* * This program initializes DR_HOOK and aborts in a DR_HOOK-traced callstack with a call to * `drhook_abort(...)` which delegates to user-customizable abort function. * By default the abort function is ABOR1. This test can be configured to instead set a * custom abort function by setting in the environment "CUSTOM_ABORT=1" * Unless "DR_HOOK_IGNORE_SIGNALS=6" is specified in the environment, DR_HOOK will also catch * the SIGABRT and print the drhook_calltree when "CUSTOM_ABORT=1" * * Note that the abort may be disabled altogether with environment "ABORT=0", which is useful * to see if the program manages to succeed otherwise. */ #include #include #include #include #include "drhook.h" #include "mpl.h" int do_abort(); int mpl(); void custom_abort( const char* file, int line, const char* txt ) { fprintf(stderr,"custom_abort(%s,%d,\"%s\")\n",file,line,txt); abort(); } void function_2 () { DRHOOK_START(function_2); static int count = 0; ++count; usleep(100); if( count == 3 ) { if( do_abort() ) { drhook_abort(__FILE__,__LINE__,"abort from call2"); } } DRHOOK_END(); } void function_1 () { int i; DRHOOK_START(function_1); for( i=0; i<5; ++i ) { function_2(); } DRHOOK_END(); } void setup_test(int argc, char* argv[]) { //ec_args(argc,argv); const int OVERWRITE = 1; const int DONT_OVERWRITE = 0; setenv("DR_HOOK", "1", OVERWRITE ); setenv("DR_HOOK_SILENT", "1", DONT_OVERWRITE ); char* env = getenv("CUSTOM_ABORT"); int use_custom_abort = env ? atoi(env) : 0; if( use_custom_abort ) { drhook_set_abort( custom_abort ); } if( mpl() ) { mpl_init(); } drhook_init(argc,argv); } void end_test() { if( mpl() ) { mpl_end(); } } int do_abort() { char* env = getenv("ABORT"); return env ? atoi(env) : 1; } int mpl() { char* env = getenv("MPL"); return env ? atoi(env) : 0; } int main(int argc, char* argv[]) { setup_test(argc,argv); DRHOOK_START(main); function_1(); DRHOOK_END(); end_test(); printf("test completed\n"); } fiat-ecmwf-2.0.0/tests/test-install.sh.in0000775000175000017500000000245415157200431020453 0ustar alastairalastair#!/usr/bin/env bash # (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # Usage: # test-install.sh [CMAKE_ARGUMENTS] SOURCE=@CMAKE_CURRENT_SOURCE_DIR@/test_install BUILD=@CMAKE_CURRENT_BINARY_DIR@/test_install # Error handling function test_failed { EXIT_CODE=$? { set +ex; } 2>/dev/null if [ $EXIT_CODE -ne 0 ]; then echo "+++++++++++++++++" echo "Test failed" echo "+++++++++++++++++" fi exit $EXIT_CODE } trap test_failed EXIT set -e -o pipefail set -x # Start with clean build rm -rf $BUILD if [ -z ${fiat_ROOT+x} ]; then export fiat_DIR=@PROJECT_BINARY_DIR@ else echo "fiat_ROOT=$fiat_ROOT" fi export ecbuild_DIR=@ecbuild_DIR@ # Build mkdir -p $BUILD && cd $BUILD cmake $SOURCE \ -DCMAKE_BUILD_TYPE=RelWithDebInfo \ -DECBUILD_2_COMPAT=OFF \ "$@" make VERBOSE=1 if [ -f bin/main_dp ] ; then bin/main_dp fi if [ -f bin/main_sp ] ; then bin/main_sp fi { set +ex; } 2>/dev/null echo "+++++++++++++++++" echo "Test passed" echo "+++++++++++++++++" fiat-ecmwf-2.0.0/tests/CMakeLists.txt0000664000175000017500000002764315157200431017633 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. if( HAVE_TESTS ) set( CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} ) if( HAVE_MPI AND MPIEXEC ) set (MPI_OPTS "" CACHE STRING "system depended srun or mpirun options (partition, time, account, ...)") set( LAUNCH ${MPIEXEC} ${MPI_OPTS} ${MPIEXEC_NUMPROC_FLAG} 1 ) else() set( LAUNCH ${CMAKE_CROSSCOMPILING_EMULATOR} ) endif() # link tests against shared fiat library if it has been built, static library otherwise if (TARGET fiat) set( fiatlib fiat ) elseif( TARGET fiat-static ) set( fiatlib fiat-static ) endif() if( HAVE_OMP ) set( OMP OpenMP::OpenMP_Fortran ) endif() if( HAVE_FCKIT ) list( APPEND FCKIT_DEFINITIONS WITH_FCKIT ) list( APPEND FCKIT_LIB fckit ) endif() if( HAVE_FCKIT AND fckit_VERSION VERSION_GREATER_EQUAL 0.9.1 ) ecbuild_add_executable( TARGET fiat-test-abort-exception-handler SOURCES test_abort_exception_handler.F90 test_abort_exception_handler.cc LIBS ${fiatlib} fckit LINKER_LANGUAGE Fortran NOINSTALL) add_test(NAME fiat_test_abort_exception_handler COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" "-DLAUNCH=${LAUNCH}" "-DPASS_REGULAR_EXPRESSION=problem in function_2" -P ${CMAKE_CURRENT_SOURCE_DIR}/test_program_output.cmake RESOURCE_LOCK drhook_lockfile ) endif() add_subdirectory( drhook ) add_subdirectory( gstats ) # ---------------------------------------------------------------------------------------- # Test: fiat_test_drhook_no_output # # Ensures that no output is generated with DR_HOOK_SILENT=1 ecbuild_add_executable( TARGET fiat-test-drhook-no-output SOURCES test_drhook_no_output.c LIBS ${fiatlib} LINKER_LANGUAGE C NOINSTALL ) add_test( NAME fiat_test_drhook_no_output COMMAND ${CMAKE_COMMAND} "-DLAUNCH=${LAUNCH}" "-DEXECUTABLE=$" -P ${CMAKE_CURRENT_SOURCE_DIR}/test_drhook_no_output.cmake ) set_tests_properties(fiat_test_drhook_no_output PROPERTIES ENVIRONMENT "DR_HOOK_ASSERT_MPI_INITIALIZED=0" ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_drhook_abort_my_abort, fiat_test_drhook_abort_abor1fl # # Test that we can use drhook within C and register a custom abort ecbuild_add_executable( TARGET fiat-test-drhook-abort SOURCES test_drhook_abort.c LIBS ${fiatlib} LINKER_LANGUAGE C NOINSTALL ) add_test( NAME fiat_test_drhook_abort_abor1fl COMMAND fiat-test-drhook-abort ) set_tests_properties(fiat_test_drhook_abort_abor1fl PROPERTIES ENVIRONMENT "DR_HOOK_ASSERT_MPI_INITIALIZED=0" PASS_REGULAR_EXPRESSION "ABOR1.*EC_DRHOOK.*\[DrHookCallTree\]" RESOURCE_LOCK drhook_lockfile ) add_test( NAME fiat_test_drhook_abort_custom_abort COMMAND fiat-test-drhook-abort ) set_tests_properties(fiat_test_drhook_abort_custom_abort PROPERTIES ENVIRONMENT "CUSTOM_ABORT=1;DR_HOOK_ASSERT_MPI_INITIALIZED=0" PASS_REGULAR_EXPRESSION "custom_abort.*EC_DRHOOK.*\[DrHookCallTree\]" RESOURCE_LOCK drhook_lockfile ) # ---------------------------------------------------------------------------------------- ecbuild_add_test( TARGET fiat_test_drhook_fortran SOURCES test_drhook_fortran.F90 LIBS ${fiatlib} ${OMP} ${FCKIT_LIB} LINKER_LANGUAGE Fortran DEFINITIONS ${FCKIT_DEFINITIONS}) set_tests_properties(fiat_test_drhook_fortran PROPERTIES ENVIRONMENT "MPL=0;DR_HOOK_ASSERT_MPI_INITIALIZED=0;DR_HOOK_OPT=NOPROPAGATE_SIGNALS" PASS_REGULAR_EXPRESSION "EC_DRHOOK.*\[DrHookCallTree\]" RESOURCE_LOCK drhook_lockfile ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_drhook_counters if( HAVE_DR_HOOK_PAPI ) ecbuild_add_test(TARGET fiat_test_drhook_counters SOURCES test_drhook_counters.F90 test_drhook_counters_stream.F90 test_drhook_counters_gemm.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran ENVIRONMENT "DR_HOOK_ASSERT_MPI_INITIALIZED=0;FIAT_UNIT_TEST=1" ) target_compile_definitions( fiat_test_drhook_counters PRIVATE OMP ) if( NOT HAVE_MPI ) target_compile_definitions( fiat_test_drhook_counters PRIVATE NOMPI ) endif() if( CMAKE_Fortran_COMPILER_ID MATCHES Intel ) set_source_files_properties(test_drhook_counters_stream.F90 PROPERTIES COMPILE_OPTIONS "-qopt-prefetch-distance=64,12;-qopt-streaming-cache-evict=0;-qopt-streaming-stores always;-qopt-zmm-usage=high") endif() find_package( OpenMP COMPONENTS Fortran ) if( TARGET OpenMP::OpenMP_Fortran ) target_link_libraries( fiat_test_drhook_counters OpenMP::OpenMP_Fortran ) endif() if( NOT BLAS_LIBRARIES ) find_package( MKL QUIET ) if( MKL_LIBRARIES ) set( BLAS_LIBRARIES ${MKL_LIBRARIES} ) else() find_package( BLAS QUIET ) endif() endif() if( BLAS_LIBRARIES ) target_link_libraries( fiat_test_drhook_counters ${BLAS_LIBRARIES} ) target_compile_definitions( fiat_test_drhook_counters PUBLIC HAVE_BLAS ) endif() endif() # ---------------------------------------------------------------------------------------- # Tests: fiat_test_ec_args_fortran ecbuild_add_test( TARGET fiat_test_ec_args_fortran SOURCES test_ec_args_fortran.F90 ARGS arg1 arg2 arg3 LIBS ${fiatlib} ${OMP} LINKER_LANGUAGE Fortran ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_bytes_io ecbuild_add_test( TARGET fiat_test_bytes_io SOURCES test_bytes_io.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_byteswap ecbuild_add_test( TARGET fiat_test_byteswap SOURCES test_byteswap.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_checksum_c ecbuild_add_test( TARGET fiat_test_checksum_c SOURCES test_checksum.c LIBS ${fiatlib} ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_checksum ecbuild_add_test( TARGET fiat_test_checksum SOURCES test_checksum.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_mpl_no_output # ensures that no output is generated in this test upon mpl_init() and mpl_end() ecbuild_add_executable( TARGET fiat-test-mpl-no-output SOURCES test_mpl_no_output.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) add_test(NAME fiat_test_mpl_no_output COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" "-DLAUNCH=${LAUNCH}" -P ${CMAKE_CURRENT_SOURCE_DIR}/test_mpl_no_output.cmake ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_mpl_split_comm # test that MPL split communicator functionality works ecbuild_add_executable( TARGET fiat-test-mpl-split-comm SOURCES test_mpl_split_comm.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_mpl_split_comm COMMAND fiat-test-mpl-split-comm CONDITION HAVE_MPI MPI 4 ) # ---------------------------------------------------------------------------------------- # Tests: fiat_test_abor1 # # Test abor1 function, and check the error message is printed ecbuild_add_executable( TARGET fiat-test-abor1 SOURCES test_abor1.F90 LIBS ${fiatlib} ${OMP} LINKER_LANGUAGE Fortran NOINSTALL ) add_test(NAME fiat_test_abor1 COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" "-DPASS_REGULAR_EXPRESSION=ABOR1.*aborting from OpenMP parallel region" -P ${CMAKE_CURRENT_SOURCE_DIR}/test_program_output.cmake RESOURCE_LOCK drhook_lockfile ) #----------------------------------------------------------------------------------------- # Tests: fiat_test_alltoallv # # ecbuild_add_test( TARGET fiat_test_alltoallv SOURCES alltoallv.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_MPI MPI 2) #----------------------------------------------------------------------------------------- # Tests: fiat_test_gatherv # # ecbuild_add_test( TARGET fiat_test_gatherv SOURCES gatherv.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_MPI MPI 2) #----------------------------------------------------------------------------------------- # Tests: fiat_test_allgatherv # # ecbuild_add_test( TARGET fiat_test_allgatherv SOURCES allgatherv.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_MPI MPI 2) #----------------------------------------------------------------------------------------- # Tests: fiat_test_scatterv # # ecbuild_add_test( TARGET fiat_test_scatterv SOURCES scatterv.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran CONDITION HAVE_MPI MPI 2) #----------------------------------------------------------------------------------------- # Tests: fiat_test_displs_container # # test the linled_list needed for the non-blocking collectives ecbuild_add_test( TARGET fiat_test_displs_container SOURCES displs_container.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran) #----------------------------------------------------------------------------------------- # Tests: fiat_test_mpi_serial # # ecbuild_add_executable( TARGET fiat-test-mpi-serial SOURCES test_mpi_serial.F90 LIBS ${fiatlib} ${MPI_SERIAL_LIBRARIES} LINKER_LANGUAGE Fortran NOINSTALL ) ecbuild_add_test( TARGET fiat_test_mpi_serial_n0 COMMAND fiat-test-mpi-serial) set_tests_properties(fiat_test_mpi_serial_n0 PROPERTIES FAIL_REGULAR_EXPRESSION "My rank number is *1" ) if (HAVE_MPI) ecbuild_add_test( TARGET fiat_test_mpi_serial_n2 COMMAND fiat-test-mpi-serial MPI 2) set_tests_properties(fiat_test_mpi_serial_n2 PROPERTIES FAIL_REGULAR_EXPRESSION "My rank number is *1" ) endif() # ---------------------------------------------------------------------------------------- # Tests: fiat_test_namelist ecbuild_add_executable( TARGET fiat_test_namelist SOURCES test_namelist.F90 LIBS ${fiatlib} LINKER_LANGUAGE Fortran NOINSTALL ) add_test(NAME fiat_test_namelist COMMAND ${CMAKE_COMMAND} "-DEXECUTABLE=$" "-DPASS_REGULAR_EXPRESSION=ABOR1.*POSNAM:CANNOT LOCATE NAM_NONPRESENT" -P ${CMAKE_CURRENT_SOURCE_DIR}/test_program_output.cmake ) # ---------------------------------------------------------------------------------------- # Test installation of fiat is working configure_file( test-install.sh.in ${CMAKE_CURRENT_BINARY_DIR}/test-install.sh @ONLY ) unset( _test_args ) if( CMAKE_TOOLCHAIN_FILE ) list( APPEND _test_args "-DCMAKE_TOOLCHAIN_FILE=${CMAKE_TOOLCHAIN_FILE}" ) endif() foreach( lang C CXX Fortran ) if( CMAKE_${lang}_COMPILER ) list( APPEND _test_args "-DCMAKE_${lang}_COMPILER=${CMAKE_${lang}_COMPILER}" ) endif() if( CMAKE_${lang}_FLAGS ) list( APPEND _test_args "-DCMAKE_${lang}_FLAGS=${CMAKE_${lang}_FLAGS}" ) endif() if( CMAKE_EXE_LINKER_FLAGS ) list( APPEND _test_args "-DCMAKE_EXE_LINKER_FLAGS=${CMAKE_EXE_LINKER_FLAGS}" ) endif() endforeach() add_test( NAME fiat_test_install COMMAND ${CMAKE_CURRENT_BINARY_DIR}/test-install.sh ${_test_args} ) # ---------------------------------------------------------------------------------------- endif(HAVE_TESTS) fiat-ecmwf-2.0.0/tests/test_ec_args_fortran.F900000664000175000017500000000256515157200431021544 0ustar alastairalastair! (C) Copyright 2021- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Testing of ec_args; expected to be launched with 3 arguments: ! arg1 arg2 arg3 ! #define FAIL(msg) call fail_impl(msg,__LINE__) program test_ec_args use iso_c_binding use ec_args_mod implicit none integer(c_int) :: argc, iarg argc = ec_argc() if( argc /= 0 ) FAIL("argc should be zero before initialisation") ! Setup ec_args --> computes command line arguments in Fortran and stores in C for C to use as well call ec_args() argc = ec_argc() if( argc == 0 ) FAIL("argc should be non-zero after initialisation") write(0,*) "program name = ", ec_argv(0) if( argc /= 4 ) FAIL("4 arguments expected") if( ec_argv(1) /= "arg1" ) FAIL("unexpected value 'arg1'") if( ec_argv(2) /= "arg2" ) FAIL("unexpected value 'arg2'") if( ec_argv(3) /= "arg3" ) FAIL("unexpected value 'arg3'") contains subroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_ec_args.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine end program fiat-ecmwf-2.0.0/tests/test_mpl_split_comm.F900000664000175000017500000000375315157200431021424 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. PROGRAM TEST_MPL_SPLIT_COMM USE EC_PARKIND, ONLY: JPIM USE MPL_MODULE, ONLY: MPL_INIT, MPL_NPROC, MPL_MYRANK, MPL_COMM, MPL_COMM_SPLIT, MPL_SETDFLT_COMM, & & MPL_ABORT, MPL_END IMPLICIT NONE INTEGER(JPIM), PARAMETER :: STDOUT = 6 INTEGER(JPIM) :: IGLOBAL_NPROC, IGLOBAL_RANK, ISPLIT_COLOUR, IERROR, ISPLIT_COMM, IDUMMY_COMM INTEGER(JPIM) :: ISPLIT_RANK, ISPLIT_NPROC CALL MPL_INIT IGLOBAL_NPROC = MPL_NPROC() IGLOBAL_RANK = MPL_MYRANK() ! First rank in group 0, others in group 1 ISPLIT_COLOUR = MERGE(0, 1, IGLOBAL_RANK == 1) ! Split world communicator according to rank colour CALL MPL_COMM_SPLIT(MPL_COMM, ISPLIT_COLOUR, IGLOBAL_RANK, ISPLIT_COMM, IERROR) IF (IERROR /= 0) THEN CALL MPL_ABORT("TEST_MPL_SPLIT_COMM: MPL_COMM_SPLIT failed") ENDIF ! Set new split communicator as default CALL MPL_SETDFLT_COMM(ISPLIT_COMM, IDUMMY_COMM) ! Get rank and comm size in new split communicator ISPLIT_RANK = MPL_MYRANK() ISPLIT_NPROC = MPL_NPROC() ! Check all values are correct IF (IGLOBAL_RANK == 1) THEN IF (ISPLIT_NPROC /= 1) THEN CALL MPL_ABORT("TEST_MPL_SPLIT_COMM: 1st split comm does not have 1 rank") ENDIF IF (ISPLIT_RANK /= 1) THEN CALL MPL_ABORT("TEST_MPL_SPLIT_COMM: 1st global rank is not 1st rank in 1st split comm") ENDIF ELSE IF (ISPLIT_NPROC /= IGLOBAL_NPROC - 1) THEN CALL MPL_ABORT("TEST_MPL_SPLIT_COMM: 2nd split comm does not have correct # ranks") ENDIF IF (ISPLIT_RANK /= IGLOBAL_RANK - 1) THEN CALL MPL_ABORT("TEST_MPL_SPLIT_COMM: rank does not have correct number in 2nd split comm") ENDIF ENDIF CALL MPL_END(LDMEMINFO=.FALSE.) END PROGRAM TEST_MPL_SPLIT_COMM fiat-ecmwf-2.0.0/tests/test_bytes_io.F900000664000175000017500000000620115157200431020212 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! ! Simple Test program ! subroutine fail_impl(msg,line) character(*) :: msg integer :: line write(0,'(A,I0,A)') "TEST FAILED in test_bytes_io.F90 @ line ",line," :" write(0,*) msg stop 1 end subroutine #define FAIL(msg) call fail_impl(msg,__LINE__) program bytes_io_test use EC_PARKIND, only: jpim, jprd use bytes_io_mod use yomhook, only: lhook implicit none integer(jpim) :: unit, iret, ibuf, nbytes integer(jpim) :: nbuffer(100) integer(jpim), allocatable :: nrbuffer(:) real(jprd) :: zbuffer(50) real(jprd), allocatable :: zrbuffer(:) integer(jpim) :: nrsize integer(jpim), parameter :: sizeof_int = 4 integer(jpim), parameter :: sizeof_real = 8 ! Turn off DRHOOK, to avoid MPI init during testing lhook = .False. do ibuf=1,size(nbuffer) nbuffer(ibuf)=ibuf enddo call bytes_io_open( unit, "testfile_bytes_io", "w", iret ) if( iret < 0 ) FAIL("open for write failed") call bytes_io_write( unit, size(nbuffer), sizeof_int, iret ) if( iret < 0 ) FAIL("writing failed") call bytes_io_write( unit, nbuffer, size(nbuffer)*sizeof_int, iret ) if( iret < 0 ) FAIL("writing failed") call bytes_io_close( unit, iret ) if( iret < 0 ) FAIL("close failed") call bytes_io_open( unit, "testfile_bytes_io", "r", iret) if( iret < 0 ) FAIL("open for read failed") call bytes_io_read( unit, nrsize, sizeof_int, iret ) if( iret < 0 ) FAIL("reading failed") allocate( nrbuffer(nrsize) ) call bytes_io_read( unit, nrbuffer, nrsize*sizeof_int, iret ) if( iret < 0 ) FAIL("reading failed") call bytes_io_close( unit, iret ) if( iret < 0 ) FAIL("close failed") do ibuf=1,size(nbuffer) if( nrbuffer(ibuf) /= nbuffer(ibuf) ) then FAIL("rbuffer read not equal to nbuffer written") endif enddo !============================= do ibuf=1,size(zbuffer) zbuffer(ibuf)=ibuf enddo call bytes_io_open( unit, "testfile_bytes_io", "w", iret ) if( iret < 0 ) FAIL("open for write failed") call bytes_io_write( unit, size(zbuffer), sizeof_int, iret ) if( iret < 0 ) FAIL("writing failed") call bytes_io_write( unit, zbuffer, size(zbuffer)*sizeof_real, iret ) if( iret < 0 ) FAIL("writing failed") call bytes_io_close( unit, iret ) if( iret < 0 ) FAIL("close failed") call bytes_io_open( unit, "testfile_bytes_io", "r", iret) if( iret < 0 ) FAIL("open for read failed") call bytes_io_read( unit, nrsize, sizeof_int, iret ) if( iret < 0 ) FAIL("reading failed") if( nrsize /= size(zbuffer) ) FAIL("size does not match") allocate( zrbuffer(nrsize) ) call bytes_io_read( unit, zrbuffer, nrsize*sizeof_real, iret ) if( iret < 0 ) FAIL("reading failed") call bytes_io_close( unit, iret ) if( iret < 0 ) FAIL("close failed") do ibuf=1,size(zbuffer) if( zrbuffer(ibuf) /= zbuffer(ibuf) ) then FAIL("zrbuffer read not equal to zbuffer written") endif enddo write(0,'(A)') "SUCCESS" end program fiat-ecmwf-2.0.0/src/0000775000175000017500000000000015157200431014504 5ustar alastairalastairfiat-ecmwf-2.0.0/src/parkind/0000775000175000017500000000000015157200431016134 5ustar alastairalastairfiat-ecmwf-2.0.0/src/parkind/parkind1.F900000664000175000017500000000310115157200431020120 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE PARKIND1 ! ! *** Define usual kinds for strong typing *** ! USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T IMPLICIT NONE PRIVATE :: C_INTPTR_T SAVE ! ! Integer Kinds ! ------------- ! INTEGER, PARAMETER :: JPIT = SELECTED_INT_KIND(2) INTEGER, PARAMETER :: JPIS = SELECTED_INT_KIND(4) INTEGER, PARAMETER :: JPIM = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: JPIB = SELECTED_INT_KIND(12) !Special integer type to be used for sensative adress calculations !should be *8 for a machine with 8byte adressing for optimum performance INTEGER, PARAMETER :: JPIA = C_INTPTR_T ! ! Real Kinds ! ---------- ! INTEGER, PARAMETER :: JPRT = SELECTED_REAL_KIND(2,1) INTEGER, PARAMETER :: JPRS = SELECTED_REAL_KIND(4,2) INTEGER, PARAMETER :: JPRM = SELECTED_REAL_KIND(6,37) #ifdef PARKIND1_SINGLE INTEGER, PARAMETER :: JPRB = SELECTED_REAL_KIND(6,37) #else INTEGER, PARAMETER :: JPRB = SELECTED_REAL_KIND(13,300) #endif ! Double real for C code and special places requiring ! higher precision. INTEGER, PARAMETER :: JPRD = SELECTED_REAL_KIND(13,300) ! Logical Kinds for RTTOV.... INTEGER, PARAMETER :: JPLM = JPIM !Standard logical type END MODULE PARKIND1 fiat-ecmwf-2.0.0/src/parkind/CMakeLists.txt0000664000175000017500000000167215157200431020702 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) foreach( prec sp dp ) if( HAVE_${prec} ) set( target parkind_${prec} ) ecbuild_add_library( TARGET ${target} SOURCES parkind1.F90 parkind2.F90 ) fiat_target_fortran_module_directory( TARGET ${target} MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/${target} INSTALL_DIRECTORY module/${target} ) endif() endforeach() if( TARGET parkind_sp ) target_compile_definitions( parkind_sp PRIVATE PARKIND1_SINGLE ) endif() fiat-ecmwf-2.0.0/src/parkind/parkind2.F900000664000175000017500000000144315157200431020130 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE PARKIND2 ! ! *** Define huge kinds for strong typing *** ! IMPLICIT NONE SAVE ! ! Integer Kinds ! ------------- ! INTEGER, PARAMETER :: JPIH = SELECTED_INT_KIND(18) ! ! Real Kinds ! ---------- ! #ifdef REALHUGE INTEGER, PARAMETER :: JPRH = SELECTED_REAL_KIND(31,291) #else INTEGER, PARAMETER :: JPRH = SELECTED_REAL_KIND(13,300) #endif ! END MODULE PARKIND2 fiat-ecmwf-2.0.0/src/fiat/0000775000175000017500000000000015157200431015427 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/gstats/0000775000175000017500000000000015157200431016734 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/gstats/gstats_psut.F900000664000175000017500000000312615157200431021576 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS_PSUT ! MEASURE PARALLELL START UP TIME USE EC_PARKIND, ONLY: JPRD, JPIM USE YOMGSTATS, ONLY: NPROC_STATS, JPTAGSTAT, MYPROC_STATS, TIME_START, TIMELCALL, NPRCIDS_STATS USE MPL_MODULE, ONLY: MPL_BARRIER, MPL_SEND, MPL_RECV IMPLICIT NONE INTEGER(KIND=JPIM) :: ITAG, ILSEND, ILBUF, JROC, IRECV, ISEND REAL(KIND=JPRD) :: ZTBUF(2), ZCLOCK, ZCLOCKB #include "user_clock.intfb.h" IF (NPROC_STATS > 1) THEN CALL USER_CLOCK(PELAPSED_TIME=ZCLOCKB) CALL MPL_BARRIER CALL USER_CLOCK(PELAPSED_TIME=ZCLOCK) ITAG = JPTAGSTAT IF (MYPROC_STATS == 1 ) THEN ALLOCATE(TIME_START(NPROC_STATS)) TIME_START(1) = ZCLOCKB - TIMELCALL(0) ILBUF = 2 ENDIF DO JROC = 2, NPROC_STATS IF (MYPROC_STATS .EQ. JROC ) THEN ZTBUF(1) = ZCLOCKB ZTBUF(2) = ZCLOCK ILSEND = 2 ISEND = 1 CALL MPL_SEND(ZTBUF(1:ILSEND), KDEST=NPRCIDS_STATS(ISEND), KTAG=ITAG, CDSTRING='SUSTATS:') ELSEIF (MYPROC_STATS == 1 ) THEN IRECV = JROC CALL MPL_RECV(ZTBUF(1:ILBUF), KSOURCE=NPRCIDS_STATS(IRECV), KTAG=ITAG, CDSTRING='SUSTATS:') TIME_START(JROC) = ZTBUF(1) - TIMELCALL(0) - (ZTBUF(2) - ZCLOCK) ENDIF CALL MPL_BARRIER ENDDO ENDIF END SUBROUTINE GSTATS_PSUT fiat-ecmwf-2.0.0/src/fiat/gstats/gstats_label.F900000664000175000017500000000213315157200431021657 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS_LABEL(KNUM, CTYPE, CDESC) USE EC_PARKIND, ONLY: JPIM USE YOMGSTATS, ONLY: JPMAXSTAT, CCDESC, CCTYPE, JPERR IMPLICIT NONE INTEGER(KIND=JPIM) :: KNUM CHARACTER(*) :: CDESC CHARACTER(*) :: CTYPE INTEGER(KIND=JPIM) :: ILEN, ITLEN IF (KNUM < 0 .OR. KNUM > JPMAXSTAT) CALL ABOR1('GSTATS_LABEL:ILLEGAL KNUM') ILEN = MIN(LEN(CDESC), LEN(CCDESC(KNUM))) ITLEN = MIN(LEN(CTYPE), LEN(CCTYPE(KNUM))) IF (CCDESC(KNUM) == '') THEN CCDESC(KNUM) = CDESC(1:ILEN) CCTYPE(KNUM) = CTYPE(1:ITLEN) ELSEIF (CCDESC(KNUM)(1:ILEN) /= CDESC(1:ILEN)) THEN WRITE(JPERR,*) 'LABEL', KNUM, ' USED ', CCDESC(KNUM) CALL ABOR1('GSTATS_LABEL:OVERWRITE OF USED LABEL') ENDIF END SUBROUTINE GSTATS_LABEL fiat-ecmwf-2.0.0/src/fiat/gstats/gstats_barrier2.F900000664000175000017500000000160215157200431022310 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS_BARRIER2(KNUM) USE EC_PARKIND, ONLY: JPIM USE YOMGSTATS, ONLY: LBARRIER_STATS2, NBAR_PTR, NBAR2 USE MPL_MODULE, ONLY: MPL_BARRIER IMPLICIT NONE INTEGER(KIND=JPIM) :: KNUM INTEGER(KIND=JPIM) :: INUM IF (LBARRIER_STATS2) THEN IF (NBAR_PTR(KNUM) == 0) THEN INUM = NBAR2 NBAR2 = NBAR2 + 1 NBAR_PTR(KNUM) = INUM ENDIF INUM = NBAR_PTR(KNUM) CALL GSTATS(INUM, 0) CALL MPL_BARRIER() CALL GSTATS(INUM, 1) ENDIF END SUBROUTINE GSTATS_BARRIER2 fiat-ecmwf-2.0.0/src/fiat/gstats/gstats_print.F900000664000175000017500000011475215157200431021747 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS_PRINT(KULOUT,PAVEAVE,KLEN) !**** *GSTATS_PRINT* - print timing statistics ! PURPOSE. ! -------- ! To print out timings gathered by GSTATS !** INTERFACE. ! ---------- ! *CALL* *GSTATS_PRINT* ! EXPLICIT ARGUMENTS None ! -------------------- ! IMPLICIT ARGUMENTS ! -------------------- ! Module YOMSTATS ! METHOD. ! ------- ! EXTERNALS. ! ---------- ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! Mats Hamrud ECMWF ! MODIFICATIONS. ! -------------- ! ORIGINAL : 98-11-15 ! D.Salmond: 99-09-21 : Timer for SLCOMM2 ! G.Mozdzynski 05-09-25 : fix master ncalls overwrite for nproc>1 ! C.Larsson 8-May-2006 : Added xml file output ! G.Mozdzynski 16-Oct-2007 : xml file output under switch LXML_STATS ! P.Towers 11-May-2011 : mpl comms statistics output ! F. Vana 05-Mar-2015 Support for single precision ! G. Mozdzynski 18-Aug-2015 Avoid confusion, procs are tasks ! M. Plesske 05-Nov-2025 added LCSV_STATS ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPRD, JPIM USE YOMGSTATS, ONLY: JPMAXDELAYS, JPMAXSTAT, NPROC_STATS, LXML_STATS, LCSV_STATS, MYPROC_STATS, LSYNCSTATS, & & LDETAILED_STATS, LSTATS_COMMS, LSTATS_OMP, LBARRIER_STATS2, JBMAXBASE, & & NBAR_PTR, CCDESC, CCTYPE, LSTATS, TIMESUM, TIMESQSUM, TIMEMAX, TIMESUMB, & & TIMELCALL, NCALLS, TTCPUSUM, TVCPUSUM, JPTAGSTAT, NPRCIDS_STATS, LSTATS_MPL, & & NUMSEND, SENDBYTES, NUMRECV, RECVBYTES, LSTATSCPU, NPRNT_STATS, TIME_START, & & UNKNOWN_NUMSEND, UNKNOWN_NUMRECV, UNKNOWN_SENDBYTES, UNKNOWN_RECVBYTES, & & NDELAY_INDEX, NDELAY_COUNTER, TDELAY_VALUE, CDELAY_TIME, LTRACE_STATS, & & NCALLS_TOTAL, NTRACE_STATS, NCALL_TRACE, TIME_TRACE, LSTATS_MEM, NTMEM USE MPL_MODULE, ONLY: MPL_SEND, MPL_RECV, MPL_BARRIER IMPLICIT NONE INTEGER(KIND=JPIM) :: KULOUT,KLEN REAL(KIND=JPRD) :: PAVEAVE(0:KLEN) CHARACTER*7 CLACTION(0:3) CHARACTER(LEN=JPMAXDELAYS*10) CLTEMP CHARACTER(LEN=128) :: CLCSVNAME CHARACTER(LEN=32) :: CLCSVCOLS(15) INTEGER(KIND=JPIM),PARAMETER :: JPARRAYS=8 REAL(KIND=JPRD) :: ZREABUF(JPARRAYS*(JPMAXSTAT+1)) REAL(KIND=JPRD) :: ZAVEAVE(0:JPMAXSTAT),ZAVEMAX(0:JPMAXSTAT),ZTIMELCALL(0:JPMAXSTAT),& &ZTHISTIME(0:JPMAXSTAT),ZFRACMAX(0:JPMAXSTAT),& &ZSUMMAX(0:JPMAXSTAT),ZSUMTOT(0:JPMAXSTAT) REAL(KIND=JPRD) :: ZT_SUM,ZT_SUM2,ZT_SUM3,ZT_SUMIO,ZT_SUM4,ZT_SUM5,ZT_SUMB REAL(KIND=JPRD) :: ZDELAY,ZDELAY_MAX REAL(KIND=JPRD) :: ZMPL(NPROC_STATS) REAL(KIND=JPRD) :: ZBAR(NPROC_STATS) REAL(KIND=JPRD) :: ZGBR(NPROC_STATS) REAL(KIND=JPRD) :: ZGB2(NPROC_STATS) REAL(KIND=JPRD) :: ZOMP(NPROC_STATS) REAL(KIND=JPRD) :: ZIO (NPROC_STATS) REAL(KIND=JPRD) :: ZSER(NPROC_STATS) REAL(KIND=JPRD) :: ZMXD(NPROC_STATS) INTEGER(KIND=JPIM) :: ICALLSX(0:JPMAXSTAT) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: ICALLS, ILBUF, ILSEND, ILRECV, & &ISEND, ITAG, JJ, JNUM, JROC, JCALL, ICALLER,IACTION INTEGER(KIND=JPIM) :: IMEM, INUM, JMEM INTEGER(KIND=JPIM) :: JDELAY, IDELAY INTEGER(KIND=JPIM) :: NSEND,NRECV ! LOCAL REAL SCALARS REAL(KIND=JPRD) :: ZAVE, ZAVETCPU, ZAVEVCPU, ZCOMTIM, ZDETAIL,& &ZFRAC, ZMAX, ZMEAN, ZSTDDEV, ZSUM, ZSUMB, & &ZTOTAL, ZTOTCPU, ZTOTUNBAL, ZTOTVCPU, & &ZUNBAL, ZMEANT, ZMAXT REAL(KIND=JPRD) :: SBYTES,RBYTES,SENDRATE,RECVRATE REAL(KIND=JPRD) :: AVGSENDLEN,AVGRECVLEN REAL(KIND=JPRD) :: MAXCOMMTIME(501:1000) REAL(KIND=JPRD) :: TOTSENDBYTES(501:1000) REAL(KIND=JPRD) :: TOTRECVBYTES(501:1000) REAL(KIND=JPRD) :: TOTSENDBYTESSUM REAL(KIND=JPRD) :: TOTRECVBYTESSUM INTEGER(KIND=JPIM) :: IXMLLUN, ICSVUN ! ------------------------------------------------------------------ ILBUF = JPARRAYS*(JPMAXSTAT+1) ILRECV = 500*4 ZAVEAVE(:) = 0.0_JPRD ZAVEMAX(:) = 0.0_JPRD ZFRACMAX(:)= 0.0_JPRD ZSUMMAX(:)= 0.0_JPRD ZSUMTOT(:)= 0.0_JPRD ! OPEN GSTATS.XML for xml statistics IF(LXML_STATS .AND. MYPROC_STATS==1)THEN IXMLLUN=40 OPEN (UNIT=IXMLLUN, FILE='gstats.xml',ACTION='write') WRITE(IXMLLUN,'(A)')'' WRITE(IXMLLUN,'(A)')'' ENDIF WRITE(KULOUT,'(A)')'===-=== START OF TIMING STATISTICS ===-===' IF(LSYNCSTATS.AND.NPROC_STATS>1) THEN WRITE(KULOUT,'(A)')'START OF TIMINGS SYNCRONIZED' ENDIF IF(LDETAILED_STATS) THEN LSTATS_COMMS=.TRUE. LSTATS_OMP=.TRUE. ENDIF IF(LBARRIER_STATS2) THEN DO JNUM=1,JBMAXBASE IF(NBAR_PTR(JNUM) > 0) THEN INUM=NBAR_PTR(JNUM) CCDESC(INUM)=CCDESC(JNUM) CCTYPE(INUM)='GB2' ENDIF ENDDO ENDIF ! Number 400 and 401 are reserved for overall GSTATS timing, so if no label is set, use "GSTATS" and "GSTATS HOOK" ! These are the labels used in gstats_ifs_setup.F90 IF (LEN_TRIM(CCDESC(400)) == 0) THEN CCDESC(400) = 'GSTATS' ENDIF IF (LEN_TRIM(CCDESC(401)) == 0) THEN CCDESC(401) = 'GSTATS HOOK' ENDIF ! CSV OUTPUT FOR EACH RANK IF (LSTATS .AND. LCSV_STATS) THEN ! OPENING THE FILE WRITE(CLCSVNAME, '(A,I0,A)') 'gstats.', MYPROC_STATS, '.csv' IF (NPROC_STATS <= 1) WRITE(KULOUT, '(A,A)') "GSTATS writing file ", CLCSVNAME IF (NPROC_STATS > 1) WRITE(KULOUT, '(A,I0,A)') "GSTATS writing files gstats.{1..", NPROC_STATS, "}.csv" OPEN (NEWUNIT=ICSVUN, FILE=CLCSVNAME, ACTION='write') !write header WRITE(ICSVUN,'(A)') 'GSTATS ID, SECTION, NUMCALLS, TOTAL TIME, MAX TIME, AVE TIME, AVE TIME CPU, AVE TIME VECTOR, STDDEV, NUMSENDS, BYTES SEND, AVE BYTES SEND, NUMRECVS, BYTES RECV, AVE BYTES RECV' ! WRITING OUTPUT FOR EVERY RECORDED GSTATS SECTION DO JNUM=0,JPMAXSTAT CLCSVCOLS(:)='NaN' IF (NCALLS(JNUM) > 1) THEN ! TIMING INFORMATION ICALLS = NCALLS(JNUM)/2 IF (ICALLS > 1) THEN ZSTDDEV = 1000._JPRD*SQRT(MAX((TIMESQSUM(JNUM)-TIMESUM(JNUM)**2/REAL(ICALLS,JPRD))/REAL(ICALLS-1,JPRD),0.0_JPRD)) ELSE ZSTDDEV= 0.0_JPRD ENDIF WRITE(CLCSVCOLS(1), '(I0)') JNUM CLCSVCOLS(2) = CCDESC(JNUM) WRITE(CLCSVCOLS(3), '(I0)') ICALLS WRITE(CLCSVCOLS(4), '(F0.6)') TIMESUM(JNUM) WRITE(CLCSVCOLS(5), '(F0.6)') TIMEMAX(JNUM)*1000._JPRD WRITE(CLCSVCOLS(6), '(F0.6)') TIMESUM(JNUM)/ICALLS*1000._JPRD WRITE(CLCSVCOLS(7), '(F0.6)') TTCPUSUM(JNUM)/ICALLS*1000._JPRD WRITE(CLCSVCOLS(8), '(F0.6)') TVCPUSUM(JNUM)/ICALLS*1000._JPRD WRITE(CLCSVCOLS(9), '(F0.6)') ZSTDDEV ! COMMUNICATION INFORMATION IF (LSTATS_MPL .AND. JNUM > 500 .AND. JNUM < 1001) THEN IF(NUMSEND(JNUM) /= 0) THEN AVGSENDLEN=SENDBYTES(JNUM)*1.E-3_JPRD/NUMSEND(JNUM) ELSE AVGSENDLEN=0.0_JPRD ENDIF IF(NUMRECV(JNUM) /= 0) THEN AVGRECVLEN=RECVBYTES(JNUM)*1.E-3_JPRD/NUMRECV(JNUM) ELSE AVGRECVLEN=0.0_JPRD ENDIF WRITE(CLCSVCOLS(10), '(I0)') NUMSEND(JNUM) WRITE(CLCSVCOLS(11), '(F0.6)') SENDBYTES(JNUM) WRITE(CLCSVCOLS(12), '(F0.6)') AVGSENDLEN WRITE(CLCSVCOLS(13), '(I0)') NUMRECV(JNUM) WRITE(CLCSVCOLS(14), '(F0.6)') RECVBYTES(JNUM) WRITE(CLCSVCOLS(15), '(F0.6)') AVGRECVLEN ENDIF ! WRITE TO CSV FILE DO JJ = 1, 14 WRITE(ICSVUN, '(2A)', advance='no') TRIM(CLCSVCOLS(JJ)), ',' ENDDO WRITE(ICSVUN, '(A)') TRIM(CLCSVCOLS(15)) ENDIF ENDDO ! CLOSING CSV FILES CLOSE(ICSVUN) ENDIF ! COLLECTING ALL INFORMATION AT RANK 1 AND COMPUTING FURTHER METRICS IF (LSTATS .AND. MYPROC_STATS /= 1) THEN JJ = 1 DO JNUM=0,JPMAXSTAT ZREABUF(JJ ) = TIMESUM(JNUM) ZREABUF(JJ+1) = TIMESQSUM(JNUM) ZREABUF(JJ+2) = TIMEMAX(JNUM) ZREABUF(JJ+3) = TIMESUMB(JNUM) ZREABUF(JJ+4) = TIMELCALL(JNUM) ZREABUF(JJ+5) = NCALLS(JNUM) ZREABUF(JJ+6) = TTCPUSUM(JNUM) ZREABUF(JJ+7) = TVCPUSUM(JNUM) JJ = JJ+JPARRAYS ENDDO ILSEND = ILBUF ISEND =1 ITAG = JPTAGSTAT CALL MPL_SEND(ZREABUF(1:ILSEND),KDEST=NPRCIDS_STATS(ISEND), & & KTAG=ITAG,CDSTRING='GSTATS_PRINT:') IF(LSTATS_MPL) THEN JJ=1 DO JNUM=501,1000 ZREABUF(JJ ) = NUMSEND(JNUM) ZREABUF(JJ+1) = SENDBYTES(JNUM) ZREABUF(JJ+2) = NUMRECV(JNUM) ZREABUF(JJ+3) = RECVBYTES(JNUM) JJ=JJ+4 ENDDO ILSEND = JJ-1 ITAG = JPTAGSTAT + 1 CALL MPL_SEND(ZREABUF(1:ILSEND),KDEST=NPRCIDS_STATS(ISEND), & & KTAG=ITAG,CDSTRING='GSTATS_PRINT:') ENDIF ELSEIF(LSTATS) THEN IF(LSTATS_MPL) THEN DO JNUM=501,1000 MAXCOMMTIME(JNUM)=0.0_JPRD TOTSENDBYTES(JNUM)=0.0_JPRD TOTRECVBYTES(JNUM)=0.0_JPRD ENDDO ENDIF DO JROC=1,NPROC_STATS IF (JROC /= 1) THEN ITAG = JPTAGSTAT CALL MPL_RECV(ZREABUF(1:ILBUF),KSOURCE=NPRCIDS_STATS(JROC), & & KTAG=ITAG,CDSTRING='GSTATS_PRINT:') JJ = 1 DO JNUM=0,JPMAXSTAT TIMESUM(JNUM) = ZREABUF(JJ ) TIMESQSUM(JNUM) = ZREABUF(JJ+1) TIMEMAX(JNUM) = ZREABUF(JJ+2) TIMESUMB(JNUM) = ZREABUF(JJ+3) TIMELCALL(JNUM) = ZREABUF(JJ+4) ICALLSX(JNUM) = NINT(ZREABUF(JJ+5)) TTCPUSUM(JNUM) = ZREABUF(JJ+6) TVCPUSUM(JNUM) = ZREABUF(JJ+7) JJ = JJ+JPARRAYS ENDDO IF(LSTATS_MPL) THEN ITAG = JPTAGSTAT+1 CALL MPL_RECV(ZREABUF(1:ILRECV),KSOURCE=NPRCIDS_STATS(JROC), & & KTAG=ITAG,CDSTRING='GSTATS_PRINT:') JJ = 1 DO JNUM=501,1000 NUMSEND(JNUM) = NINT(ZREABUF(JJ)) SENDBYTES(JNUM) = ZREABUF(JJ+1) NUMRECV(JNUM) = NINT(ZREABUF(JJ+2)) RECVBYTES(JNUM) = ZREABUF(JJ+3) JJ=JJ+4 ENDDO ENDIF ELSE ICALLSX(:)=NCALLS(:) ENDIF IF (JROC == 1) THEN ZTOTAL=TIMESUM(0) ZTOTCPU = TTCPUSUM(0) ZTOTVCPU = TVCPUSUM(0) ENDIF IF(.NOT. LSTATSCPU) THEN TTCPUSUM(1:JPMAXSTAT) = -0.0_JPRD TVCPUSUM(1:JPMAXSTAT) = -0.0_JPRD ENDIF ZT_SUM=0.0_JPRD ZT_SUM2=0.0_JPRD ZT_SUM3=0.0_JPRD ZT_SUM4=0.0_JPRD ZT_SUM5=0.0_JPRD ZT_SUMIO=0.0_JPRD ZT_SUMB=0.0_JPRD IF( LDETAILED_STATS .AND. JROC <= NPRNT_STATS ) THEN WRITE(KULOUT,'(A,I4)') 'TIMING STATISTICS:TASK=',JROC IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A)')'' ENDIF IF(NPROC_STATS > 1) THEN WRITE(KULOUT,'(A,F6.1,A)')'STARTUP COST ',& &TIME_START(JROC),' SECONDS' ENDIF WRITE(KULOUT,'(A)')& &' NUM ROUTINE '//& &'CALLS SUM(s) AVE(ms) CPUAVE(ms) VAVE(ms) '//& &'STDDEV(ms) MAX(ms) '//& &'SUMB(s) FRAC(%)' ENDIF DO JNUM=0,JPMAXSTAT IF(ICALLSX(JNUM) > 1) THEN ICALLS = ICALLSX(JNUM)/2 ZSUM = TIMESUM(JNUM) ZAVE = TIMESUM(JNUM)/ICALLS*1000._JPRD ZMAX = TIMEMAX(JNUM)*1000._JPRD ZSUMB = TIMESUMB(JNUM) ZFRAC = TIMESUM(JNUM)/ZTOTAL*100.0_JPRD ZFRACMAX(JNUM)=MAX(ZFRACMAX(JNUM),ZFRAC) ZSUMMAX(JNUM)=MAX(ZSUMMAX(JNUM),TIMESUM(JNUM)) ZSUMTOT(JNUM)=ZSUMTOT(JNUM)+ZSUM ZAVEAVE(JNUM)=ZAVEAVE(JNUM)+ZAVE ZAVEMAX(JNUM)=MAX(ZAVEMAX(JNUM),ZAVE) ZAVETCPU = TTCPUSUM(JNUM)/ICALLS*1000._JPRD ZAVEVCPU = TVCPUSUM(JNUM)/ICALLS*1000._JPRD IF(ICALLS > 1 ) THEN ZSTDDEV = 1000._JPRD*& &SQRT(MAX((TIMESQSUM(JNUM)-TIMESUM(JNUM)**2/ICALLS)& &/(ICALLS-1),0.0_JPRD)) ELSE ZSTDDEV = 0.0_JPRD ENDIF IF(CCTYPE(JNUM).EQ.'MPL') THEN ZT_SUM=ZT_SUM+ZSUM ZT_SUMB=ZT_SUMB+ZSUMB ENDIF IF(CCTYPE(JNUM).EQ.'BAR' .OR. CCTYPE(JNUM).EQ.'GBR' .OR. CCTYPE(JNUM).EQ.'GB2' ) THEN ZT_SUM4=ZT_SUM4+ZSUM ZT_SUMB=ZT_SUMB+ZSUMB ENDIF IF(CCTYPE(JNUM).EQ.'OMP') THEN ZT_SUM2=ZT_SUM2+ZSUM ZT_SUMB=ZT_SUMB+ZSUMB ENDIF IF(CCTYPE(JNUM).EQ.'IO-') THEN ZT_SUMIO=ZT_SUMIO+ZSUM ZT_SUMB=ZT_SUMB+ZSUMB ENDIF IF(CCTYPE(JNUM).EQ.'SER') THEN ZT_SUM3=ZT_SUM3+ZSUM ZT_SUMB=ZT_SUMB+ZSUMB ENDIF IF(CCTYPE(JNUM).EQ.'MXD') THEN ZT_SUM5=ZT_SUM5+ZSUM ZT_SUMB=ZT_SUMB+ZSUMB ENDIF IF( LDETAILED_STATS .AND. JROC <= NPRNT_STATS ) THEN WRITE(KULOUT,'(I4,1X,A3,1X,A40,1X,I5,6(1X,F9.1),1X,F5.1,1X,F8.2)')& &JNUM,CCTYPE(JNUM),CCDESC(JNUM),ICALLS,ZSUM,ZAVE,ZAVETCPU,ZAVEVCPU,& &ZSTDDEV,ZMAX,ZSUMB,ZFRAC IF(LXML_STATS)THEN WRITE(IXMLLUN,& & '(A,I4,A,/,A,A40,A,/,A,I5,A,/,6(A,F9.1,A,/),A,F5.1,A,/,A,F8.2,A,/,A)')& & '',& & '',CCDESC(JNUM),'',& & '',ICALLS,'',& & '',ZSUM,'',& & '',ZAVE,'',& & '',ZAVETCPU,'',& & '',ZAVEVCPU,'',& & '',ZSTDDEV,'',& & '',ZMAX,'',& & '',ZSUMB,'',& & '',ZFRAC,'',& & '' ENDIF ENDIF ENDIF ENDDO IF( LDETAILED_STATS .AND. JROC <= NPRNT_STATS ) THEN WRITE(KULOUT,*) '' WRITE(KULOUT,'((A,2F8.1))')& &'CPU-TIME AND VECTOR CPU-TIME AS PERCENT OF TOTAL ',& &TTCPUSUM(0)/TIMESUM(0)*100.0_JPRD,TVCPUSUM(0)/TIMESUM(0)*100.0_JPRD IF(LXML_STATS)THEN WRITE(IXMLLUN,'((A,F8.1,A,/,A,F8.1,A))')& &'',& &TTCPUSUM(0)/TIMESUM(0)*100.0_JPRD,& &'',& &'',& &TVCPUSUM(0)/TIMESUM(0)*100.0_JPRD,& &'' ENDIF IF(ZT_SUM > 0.0_JPRD) THEN WRITE(KULOUT,'(A,F10.1,A,F6.2,A)')'SUMMED TIME IN COMMUNICATIONS = '& & ,ZT_SUM, ' SECONDS ',ZT_SUM/TIMESUM(0)*100.0_JPRD,& &' PERCENT OF TOTAL' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A,/,A,F6.2,A)')'',& &ZT_SUM,'',& &'',ZT_SUM/TIMESUM(0)*100.0_JPRD,& &'' ENDIF ENDIF IF(ZT_SUM2 > 0.0_JPRD) THEN WRITE(KULOUT,'(A,F10.1,A,F6.2,A)')'SUMMED TIME IN PARALLEL REGIONS = '& & ,ZT_SUM2, ' SECONDS ',ZT_SUM2/TIMESUM(0)*100.0_JPRD,& &' PERCENT OF TOTAL' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A,/,A,F6.2,A)') & &'',& &ZT_SUM2, '',& &'',ZT_SUM2/TIMESUM(0)*100.0_JPRD,& &'' ENDIF ENDIF IF(ZT_SUMIO > 0.0_JPRD) THEN WRITE(KULOUT,'(A,F10.1,A,F6.2,A)')'SUMMED TIME IN I/O SECTIONS = '& & ,ZT_SUMIO, ' SECONDS ',ZT_SUMIO/TIMESUM(0)*100.0_JPRD,& &' PERCENT OF TOTAL' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A,/,A,F6.2,A)')'',& &ZT_SUMIO, '',& &'',ZT_SUMIO/TIMESUM(0)*100.0_JPRD,& &'' ENDIF ENDIF IF(ZT_SUM3 > 0.0_JPRD) THEN WRITE(KULOUT,'(A,F10.1,A,F6.2,A)')'SUMMED TIME IN SERIAL SECTIONS = '& & ,ZT_SUM3, ' SECONDS ',ZT_SUM3/TIMESUM(0)*100.0_JPRD,& &' PERCENT OF TOTAL' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A,/,A,F6.2,A)')'',& & ZT_SUM3,'',& &'',& &ZT_SUM3/TIMESUM(0)*100.0_JPRD,& &'' ENDIF ENDIF IF(ZT_SUM4 > 0.0_JPRD) THEN WRITE(KULOUT,'(A,F10.1,A,F6.2,A)')'SUMMED TIME IN BARRIERS = '& & ,ZT_SUM4, ' SECONDS ',ZT_SUM4/TIMESUM(0)*100.0_JPRD,& &' PERCENT OF TOTAL' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A,/,A,F6.2,A)')& &'',& &ZT_SUM4,'',& & '',& & ZT_SUM4/TIMESUM(0)*100.0_JPRD,'' ENDIF ENDIF IF(ZT_SUM5 > 0.0_JPRD) THEN WRITE(KULOUT,'(A,F10.1,A,F6.2,A)')'SUMMED TIME IN MIXED SECTIONS = '& & ,ZT_SUM5, ' SECONDS ',ZT_SUM5/TIMESUM(0)*100.0_JPRD,& &' PERCENT OF TOTAL' WRITE(IXMLLUN,'(A,F10.1,A,/,A,F6.2,A)')& &'',& &ZT_SUM5,'',& & '',& & ZT_SUM5/TIMESUM(0)*100.0_JPRD,'' ENDIF IF(LSTATS_COMMS.AND.LSTATS_OMP)THEN WRITE(KULOUT,'(A,F8.2)')'FRACTION OF TOTAL TIME ACCOUNTED FOR ',& & (ZT_SUM+ZT_SUM2+ZT_SUMIO+ZT_SUM3+ZT_SUM4+ZT_SUM5)/TIMESUM(0)*100.0_JPRD WRITE(KULOUT,'(A,F8.2)')'FRACTION OF TOTAL TIME ACCOUNTED FOR INCLUDING SUMB ',& & (ZT_SUM+ZT_SUM2+ZT_SUMIO+ZT_SUM3+ZT_SUM4+ZT_SUM5+ZT_SUMB)/TIMESUM(0)*100.0_JPRD WRITE(KULOUT,'(" ")') IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F8.2,A)')'',& &(ZT_SUM+ZT_SUM2+ZT_SUMIO+ZT_SUM3+ZT_SUM4+ZT_SUM5)/TIMESUM(0)*100.0_JPRD,& &'' ENDIF ENDIF ENDIF IF( LDETAILED_STATS .AND. JROC < 3 ) THEN IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF ENDIF IF( LSTATS_MPL .AND. JROC <= NPRNT_STATS ) THEN WRITE(KULOUT,'(/,A,I4,/)') 'COMMUNICATIONS STATISTICS:TASK=',JROC WRITE(KULOUT,'(A)') & &' NUM ROUTINE '//& &' SUM(s) SENDS AVG(kb) TOTAL(MB) MB/s '//& &' RECVS AVG(kb) TOTAL(MB) MB/s ' DO JNUM=501,1000 IF((NUMSEND(JNUM) /= 0 .OR. NUMRECV(JNUM) /= 0 ) & .AND. TIMESUM(JNUM) > 0.0_JPRD) THEN SENDRATE=SENDBYTES(JNUM)*1.E-6_JPRD/TIMESUM(JNUM) RECVRATE=RECVBYTES(JNUM)*1.E-6_JPRD/TIMESUM(JNUM) IF(NUMSEND(JNUM) /= 0) THEN AVGSENDLEN=SENDBYTES(JNUM)*1.E-3_JPRD/NUMSEND(JNUM) ELSE AVGSENDLEN=0.0_JPRD ENDIF IF(NUMRECV(JNUM) /= 0) THEN AVGRECVLEN=RECVBYTES(JNUM)*1.E-3_JPRD/NUMRECV(JNUM) ELSE AVGRECVLEN=0.0_JPRD ENDIF WRITE(KULOUT,'(I6,1X,A40,f6.1,2(I8,3F8.1))') & & JNUM,CCDESC(JNUM),TIMESUM(JNUM),& & NUMSEND(JNUM),AVGSENDLEN,SENDBYTES(JNUM)*1.E-6_JPRD, SENDRATE, & & NUMRECV(JNUM),AVGRECVLEN,RECVBYTES(JNUM)*1.E-6_JPRD, RECVRATE ENDIF ENDDO WRITE(KULOUT,'(/,A,I4,/)') 'UNKNOWN COMMUNICATIONS STATISTICS:TASK=', JROC WRITE(KULOUT,'(A)') & &' NUM BEFORE ROUTINE '//& &' SENDS TOTAL(MB) '//& &'RECVS TOTAL(MB) ' DO JNUM=501,1000 IF(UNKNOWN_NUMSEND(JNUM) /= 0 .OR. UNKNOWN_NUMRECV(JNUM) /= 0 ) THEN WRITE(KULOUT,'(I6,1X,A40,2(I8,F8.1))') & & JNUM,CCDESC(JNUM),& & UNKNOWN_NUMSEND(JNUM),UNKNOWN_SENDBYTES(JNUM)*1.E-6_JPRD, & & UNKNOWN_NUMRECV(JNUM),UNKNOWN_RECVBYTES(JNUM)*1.E-6_JPRD ENDIF ENDDO WRITE(KULOUT,'(7x,"TOTAL",35x,2(I8,F8.1),//)') & & SUM(UNKNOWN_NUMSEND(:)),SUM(UNKNOWN_SENDBYTES(:))*1.E-6_JPRD , & & SUM(UNKNOWN_NUMRECV(:)),SUM(UNKNOWN_RECVBYTES(:))*1.E-6_JPRD ENDIF IF(LSTATS_MPL) THEN DO JNUM=501,1000 TOTSENDBYTES(JNUM) = TOTSENDBYTES(JNUM) + SENDBYTES(JNUM) TOTRECVBYTES(JNUM) = TOTRECVBYTES(JNUM) + RECVBYTES(JNUM) IF(SENDBYTES(JNUM).GT.0.0_JPRD.OR. & & RECVBYTES(JNUM).GT.0.0_JPRD) THEN MAXCOMMTIME(JNUM) = MAX(MAXCOMMTIME(JNUM),TIMESUM(JNUM)) ENDIF ENDDO ENDIF ENDDO IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,'(A)') 'STATS FOR ALL TASKS' WRITE(KULOUT,'(A)') & &' NUM ROUTINE CALLS MEAN(ms) MAX(ms) FRAC(%) UNBAL(%)' ZTOTUNBAL = 0.0_JPRD DO JNUM=0,500 IF(NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 ZMEAN = ZAVEAVE(JNUM)/NPROC_STATS ZMAX = ZAVEMAX(JNUM) ZMEANT = ZSUMTOT(JNUM)/NPROC_STATS ZMAXT = ZSUMMAX(JNUM) IF(ZMEANT .NE. 0._JPRD)THEN ZUNBAL= (ZMAXT-ZMEANT)/ZTOTAL*100._JPRD ELSE ZUNBAL=0._JPRD ENDIF ZFRAC=ZFRACMAX(JNUM) WRITE(KULOUT,'(I4,1X,A40,1X,I8,2(1X,F13.3),2(1X,F9.2))')& &JNUM,CCDESC(JNUM),ICALLS,ZMEAN,ZMAX,ZFRAC,ZUNBAL IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,/,A,A40,A,/,A,I8,A,2(A,F13.3,A,/),2(A,F9.2,A,/),A)')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',ZMEAN,'',& &'',ZMAX,'',& &'',ZFRAC,'',& &'',ZUNBAL,'','' ENDIF ENDIF ENDDO IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF IF(LSTATS_COMMS)THEN IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,'(A)') 'STATS FOR COMMUNICATIONS' WRITE(KULOUT,'(A)') & &' NUM ROUTINE CALLS MEAN(ms) MAX(ms) FRAC(%) UNBAL(%)' ZT_SUM=0._JPRD DO JNUM=500,JPMAXSTAT IF((CCTYPE(JNUM).EQ."MPL".OR.CCTYPE(JNUM).EQ."BAR".OR.CCTYPE(JNUM).EQ."GBR".OR.CCTYPE(JNUM).EQ."GB2") & & .AND.NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 ZMEAN = ZAVEAVE(JNUM)/NPROC_STATS ZMAX = ZAVEMAX(JNUM) ZMEANT = ZSUMTOT(JNUM)/NPROC_STATS ZMAXT = ZSUMMAX(JNUM) IF(ZMEANT .NE. 0._JPRD)THEN ZUNBAL= (ZMAXT-ZMEANT)/ZTOTAL*100._JPRD ELSE ZUNBAL=0._JPRD ENDIF ZFRAC=ZFRACMAX(JNUM) ZTOTUNBAL = ZTOTUNBAL+(ZMAXT-ZMEANT) WRITE(KULOUT,'(I4,1X,A40,1X,I8,2(1X,F9.1),2(1X,F9.2))')& &JNUM,CCDESC(JNUM),ICALLS,ZMEAN,ZMAX,ZFRAC,ZUNBAL IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,/,A,A40,A,/,A,I8,A,/,2(A,F9.1,A,/),2(A,F9.2,A,/),A)')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',ZMEAN,'',& &'',ZMAX,'',& &'',ZFRAC,'',& &'',ZUNBAL,'','' ENDIF ZT_SUM=ZT_SUM+ZMEANT ENDIF ENDDO WRITE(KULOUT,*) '' WRITE(KULOUT,'(A,F10.1,A)')'SUMMED TIME IN COMMUNICATIONS = ',ZT_SUM, ' SECONDS ' IF(LSTATS_MPL) THEN WRITE(KULOUT,'(/,A,/)') 'TOTAL COMMUNICATIONS VOLUMES AND BANDWIDTH' WRITE(KULOUT,'(A)') & &' NUM ROUTINE '//& &' SUM(s) SEND(GB) RECV(GB) GB/s' DO JNUM=501,1000 IF((TOTSENDBYTES(JNUM).GT.0.0_JPRD.OR.TOTRECVBYTES(JNUM).GT.0.0_JPRD) & .AND. MAXCOMMTIME(JNUM) > 0.0_JPRD) THEN WRITE(KULOUT,'(I6,1X,A40,f6.1,2F10.1,F8.1)') & & JNUM,CCDESC(JNUM),MAXCOMMTIME(JNUM),& & TOTSENDBYTES(JNUM)*1.E-9_JPRD, & & TOTRECVBYTES(JNUM)*1.E-9_JPRD , & & (TOTSENDBYTES(JNUM)*1.E-9_JPRD)/MAXCOMMTIME(JNUM) ENDIF ENDDO TOTSENDBYTESSUM = SUM(TOTSENDBYTES) TOTRECVBYTESSUM = SUM(TOTRECVBYTES) IF( TOTSENDBYTESSUM.GT.0.0_JPRD ) THEN WRITE(KULOUT,'(/,A,42x,f6.1,2F10.1,F8.1)') & & 'TOTAL', & & SUM(MAXCOMMTIME) , & & TOTSENDBYTESSUM*1.E-9_JPRD, & & TOTRECVBYTESSUM*1.E-9_JPRD, & & (TOTSENDBYTESSUM*1.E-9_JPRD)/SUM(MAXCOMMTIME) ENDIF ENDIF IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A)')'',ZT_SUM, '' ENDIF WRITE(KULOUT,*) '' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF ENDIF IF(LSTATS_OMP)THEN IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,'(A)') 'STATS FOR PARALLEL REGIONS' WRITE(KULOUT,'(A)') & &' NUM ROUTINE CALLS MEAN(ms) MAX(ms) FRAC(%) UNBAL(%)' ZT_SUM=0._JPRD DO JNUM=500,JPMAXSTAT IF(CCTYPE(JNUM).EQ."OMP".AND.NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 ZMEAN = ZAVEAVE(JNUM)/NPROC_STATS ZMAX = ZAVEMAX(JNUM) ZMEANT = ZSUMTOT(JNUM)/NPROC_STATS ZMAXT = ZSUMMAX(JNUM) IF(ZMEANT .NE. 0._JPRD)THEN ZUNBAL= (ZMAXT-ZMEANT)/ZTOTAL*100._JPRD ELSE ZUNBAL=0._JPRD ENDIF ZFRAC=ZFRACMAX(JNUM) ZTOTUNBAL = ZTOTUNBAL+(ZMAXT-ZMEANT) WRITE(KULOUT,'(I4,1X,A40,1X,I8,2(1X,F9.1),2(1X,F9.2))')& &JNUM,CCDESC(JNUM),ICALLS,ZMEAN,ZMAX,ZFRAC,ZUNBAL IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,/,A,A40,A,/,A,I8,A,/,2(A,F9.1,A,/),2(A,F9.2,A,/),A)')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',ZMEAN,'',& &'',ZMAX,'',& &'',ZFRAC,'',& &'',ZUNBAL,'',& &'' ENDIF ZT_SUM=ZT_SUM+ZMEANT ENDIF ENDDO WRITE(KULOUT,*) '' WRITE(KULOUT,'(A,F10.1,A)')'SUMMED TIME IN PARALLEL REGIONS = ',ZT_SUM, ' SECONDS ' WRITE(KULOUT,*) '' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A)')'',ZT_SUM, '' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,'(A)') 'STATS FOR I/O REGIONS' WRITE(KULOUT,'(A)') & &' NUM ROUTINE CALLS MEAN(ms) MAX(ms) FRAC(%) UNBAL(%)' ZT_SUM=0._JPRD DO JNUM=500,JPMAXSTAT IF(CCTYPE(JNUM).EQ."IO-".AND.NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 ZMEAN = ZAVEAVE(JNUM)/NPROC_STATS ZMAX = ZAVEMAX(JNUM) ZMEANT = ZSUMTOT(JNUM)/NPROC_STATS ZMAXT = ZSUMMAX(JNUM) IF(ZMEANT .NE. 0._JPRD)THEN ZUNBAL= (ZMAXT-ZMEANT)/ZTOTAL*100._JPRD ELSE ZUNBAL=0._JPRD ENDIF ZFRAC=ZFRACMAX(JNUM) ZTOTUNBAL = ZTOTUNBAL+(ZMAXT-ZMEANT) WRITE(KULOUT,'(I4,1X,A40,1X,I8,2(1X,F9.1),2(1X,F9.2))')& &JNUM,CCDESC(JNUM),ICALLS,ZMEAN,ZMAX,ZFRAC,ZUNBAL IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,/,A,A40,A,/,A,I8,A,/,2(A,F9.1,A,/),2(A,F9.2,A,/),A)')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',ZMEAN,'','',& & ZMAX,'',& &'',ZFRAC,'',& &'',ZUNBAL,'',& &'' ENDIF ZT_SUM=ZT_SUM+ZMEANT ENDIF ENDDO WRITE(KULOUT,*) '' WRITE(KULOUT,'(A,F10.1,A)')'SUMMED TIME IN I/O REGIONS = ',& &ZT_SUM, ' SECONDS ' WRITE(KULOUT,*) '' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A)')'',ZT_SUM,'' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,'(A)') 'STATS FOR SERIAL(no OMP) REGIONS' WRITE(KULOUT,'(A)') & &' NUM ROUTINE CALLS MEAN(ms) MAX(ms) FRAC(%) UNBAL(%)' ZT_SUM=0._JPRD DO JNUM=500,JPMAXSTAT IF(CCTYPE(JNUM).EQ."SER".AND.NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 ZMEAN = ZAVEAVE(JNUM)/NPROC_STATS ZMAX = ZAVEMAX(JNUM) ZMEANT = ZSUMTOT(JNUM)/NPROC_STATS ZMAXT = ZSUMMAX(JNUM) IF(ZMEANT .NE. 0._JPRD)THEN ZUNBAL= (ZMAXT-ZMEANT)/ZTOTAL*100._JPRD ELSE ZUNBAL=0._JPRD ENDIF ZFRAC=ZFRACMAX(JNUM) ZTOTUNBAL = ZTOTUNBAL+(ZMAXT-ZMEANT) WRITE(KULOUT,'(I4,1X,A40,1X,I8,2(1X,F9.1),2(1X,F9.2))')& &JNUM,CCDESC(JNUM),ICALLS,ZMEAN,ZMAX,ZFRAC,ZUNBAL IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,A,A40,A,A,I8,A,2(A,F9.1,A),2(A,F9.2,A,/),A)')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',ZMEAN,'','',ZMAX,'',& &'',ZFRAC,'',& &'',ZUNBAL,'','' ENDIF ZT_SUM=ZT_SUM+ZMEANT ENDIF ENDDO WRITE(KULOUT,*) '' WRITE(KULOUT,'(A,F10.1,A)')'SUMMED TIME IN SERIAL REGIONS = ',ZT_SUM, ' SECONDS ' WRITE(KULOUT,*) '' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A)')'',& &ZT_SUM, '' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,'(A)') 'STATS FOR MIXED SECTIONS' WRITE(KULOUT,'(A)') & &' NUM ROUTINE CALLS MEAN(ms) MAX(ms) FRAC(%) UNBAL(%)' ZT_SUM=0._JPRD DO JNUM=500,JPMAXSTAT IF(CCTYPE(JNUM).EQ."MXD".AND.NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 ZMEAN = ZAVEAVE(JNUM)/NPROC_STATS ZMAX = ZAVEMAX(JNUM) ZMEANT = ZSUMTOT(JNUM)/NPROC_STATS ZMAXT = ZSUMMAX(JNUM) IF(ZMEANT .NE. 0._JPRD)THEN ZUNBAL= (ZMAXT-ZMEANT)/ZTOTAL*100._JPRD ELSE ZUNBAL=0._JPRD ENDIF ZFRAC=ZFRACMAX(JNUM) ZTOTUNBAL = ZTOTUNBAL+(ZMAXT-ZMEANT) WRITE(KULOUT,'(I4,1X,A40,1X,I8,2(1X,F9.1),2(1X,F9.2))')& &JNUM,CCDESC(JNUM),ICALLS,ZMEAN,ZMAX,ZFRAC,ZUNBAL IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,A,A40,A,A,I8,A,2(A,F9.1,A),2(A,F9.2,A,/),A)')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',ZMEAN,'','',ZMAX,'',& &'',ZFRAC,'',& &'',ZUNBAL,'','' ENDIF ZT_SUM=ZT_SUM+ZMEANT ENDIF ENDDO WRITE(KULOUT,*) '' WRITE(KULOUT,'(A,F10.1,A)')'SUMMED TIME IN MIXED SECTIONS = ',ZT_SUM, ' SECONDS ' WRITE(KULOUT,*) '' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,F10.1,A)')'',& &ZT_SUM, '' ENDIF IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF ENDIF WRITE(KULOUT,'(A,F10.1,A,F4.1,A)')& &'TOTAL MEASURED IMBALANCE =',ZTOTUNBAL,& &' SECONDS, ',ZTOTUNBAL/ZTOTAL*100._JPRD,' PERCENT' ELSE ZTOTAL=TIMESUM(0) ZTOTCPU = TTCPUSUM(0) ZTOTVCPU = TVCPUSUM(0) ENDIF IF ( MYPROC_STATS == 1) THEN WRITE(KULOUT,'(3(A,F11.3)/)')'TOTAL WALLCLOCK TIME ',ZTOTAL,& &' CPU TIME',ZTOTCPU,' VECTOR TIME ',ZTOTVCPU IF(LXML_STATS)THEN WRITE(IXMLLUN,'(3(A,F11.3,A,/)/)')'',ZTOTAL,& &'',& &'',ZTOTCPU,'',& & '',ZTOTVCPU,'' ENDIF ENDIF IF( LDETAILED_STATS )THEN ITAG = JPTAGSTAT ZDELAY_MAX=0.0_JPRD ZMPL(:)=0.0_JPRD ZBAR(:)=0.0_JPRD ZGBR(:)=0.0_JPRD ZGB2(:)=0.0_JPRD ZOMP(:)=0.0_JPRD ZIO (:)=0.0_JPRD ZSER(:)=0.0_JPRD ZMXD(:)=0.0_JPRD DO JROC=1,NPROC_STATS IF( JROC > 1 )THEN IF( MYPROC_STATS == JROC )THEN ISEND=1 CALL MPL_SEND(NDELAY_INDEX,KDEST=NPRCIDS_STATS(ISEND), & & KTAG=ITAG,CDSTRING='GSTATS_PRINT:') IF( NDELAY_INDEX > 0 )THEN CALL MPL_SEND(NDELAY_COUNTER(1:NDELAY_INDEX),KDEST=NPRCIDS_STATS(ISEND), & & KTAG=ITAG+1,CDSTRING='GSTATS_PRINT:') CALL MPL_SEND(TDELAY_VALUE(1:NDELAY_INDEX),KDEST=NPRCIDS_STATS(ISEND), & & KTAG=ITAG+2,CDSTRING='GSTATS_PRINT:') DO JDELAY=1,NDELAY_INDEX CLTEMP((JDELAY-1)*10+1:JDELAY*10)=CDELAY_TIME(JDELAY) ENDDO CALL MPL_SEND(CLTEMP(1:NDELAY_INDEX*10),KDEST=NPRCIDS_STATS(ISEND), & & KTAG=ITAG+3,CDSTRING='GSTATS_PRINT:') ENDIF ENDIF IF( MYPROC_STATS == 1 )THEN CALL MPL_RECV(NDELAY_INDEX,KSOURCE=NPRCIDS_STATS(JROC), & & KTAG=ITAG,CDSTRING='GSTATS_PRINT:') IF( NDELAY_INDEX > 0 )THEN CALL MPL_RECV(NDELAY_COUNTER(1:NDELAY_INDEX),KSOURCE=NPRCIDS_STATS(JROC), & & KTAG=ITAG+1,CDSTRING='GSTATS_PRINT:') CALL MPL_RECV(TDELAY_VALUE(1:NDELAY_INDEX),KSOURCE=NPRCIDS_STATS(JROC), & & KTAG=ITAG+2,CDSTRING='GSTATS_PRINT:') CALL MPL_RECV(CLTEMP(1:NDELAY_INDEX*10),KSOURCE=NPRCIDS_STATS(JROC), & & KTAG=ITAG+3,CDSTRING='GSTATS_PRINT:') DO JDELAY=1,NDELAY_INDEX CDELAY_TIME(JDELAY)=CLTEMP((JDELAY-1)*10+1:JDELAY*10) ENDDO ENDIF ENDIF ENDIF IF( MYPROC_STATS == 1 .AND. NDELAY_INDEX > 0 )THEN WRITE(KULOUT,'("+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++")') WRITE(KULOUT,'("TASK=",I6," NUMBER OF UNEXPECTED DELAYS=",I4)') JROC,NDELAY_INDEX IF( NDELAY_INDEX == JPMAXDELAYS )THEN WRITE(KULOUT,'(" NOTE THAT THE MAXIMUM NUMBER OF DELAYS HAS BEEN REACHED =",I6)')JPMAXDELAYS ENDIF ZDELAY=SUM(TDELAY_VALUE(1:NDELAY_INDEX)) WRITE(KULOUT,'("TOTAL UNEXPECTED DELAY TIME (SECS) =",F9.1)') ZDELAY ZDELAY_MAX=MAX(ZDELAY_MAX,ZDELAY) DO JDELAY=1,NDELAY_INDEX WRITE(KULOUT,'(A,":",A,":",A,1X,I4,1X,A3,1X,A40,1X,F6.1)')& &CDELAY_TIME(JDELAY)(1:2),CDELAY_TIME(JDELAY)(3:4),CDELAY_TIME(JDELAY)(5:6),& &NDELAY_COUNTER(JDELAY),CCTYPE(NDELAY_COUNTER(JDELAY)),& &CCDESC(NDELAY_COUNTER(JDELAY)),TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'MPL' ) ZMPL(JROC)=ZMPL(JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'BAR' ) ZBAR(JROC)=ZBAR(JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'GBR' ) ZGBR(JROC)=ZGBR(JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'GB2' ) ZGB2(JROC)=ZGB2(JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'OMP' ) ZOMP(JROC)=ZOMP(JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'IO-' ) ZIO (JROC)=ZIO (JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'SER' ) ZSER(JROC)=ZSER(JROC)+TDELAY_VALUE(JDELAY) IF( CCTYPE(NDELAY_COUNTER(JDELAY)) .EQ. 'MXD' ) ZMXD(JROC)=ZMXD(JROC)+TDELAY_VALUE(JDELAY) ENDDO WRITE(KULOUT,'(" ")') WRITE(KULOUT,'("TASK=",I6," UNEXPECTED DELAYS SORTED BY COUNTER")') JROC DO JNUM=500,JPMAXSTAT IDELAY=0 ZDELAY=0.0_JPRD DO JDELAY=1,NDELAY_INDEX IF( NDELAY_COUNTER(JDELAY) == JNUM )THEN IDELAY=IDELAY+1 ZDELAY=ZDELAY+TDELAY_VALUE(JDELAY) ENDIF ENDDO IF( IDELAY /= 0 )THEN WRITE(KULOUT,'(I4,1X,A3,1X,A40,1X,I4,3X,F6.1)')& &JNUM,CCTYPE(JNUM),CCDESC(JNUM),IDELAY,ZDELAY ENDIF ENDDO WRITE(KULOUT,'(" ")') WRITE(KULOUT,'(" ")') ENDIF IF (NPROC_STATS > 1) THEN CALL MPL_BARRIER(CDSTRING='GSTATS_PRINT') ENDIF ENDDO IF( MYPROC_STATS == 1 )THEN WRITE(KULOUT,'("MAXIMUM TOTAL UNEXPECTED DELAY TIME (SECS) =",F9.1)') ZDELAY_MAX WRITE(KULOUT,'(" ")') WRITE(KULOUT,'(" ")') WRITE(KULOUT,'(" TASK "," MPL "," BAR "," GBR "," GB2 "," OMP ",& &" IO- "," SER "," MXD ")') DO JROC=1,NPROC_STATS WRITE(KULOUT,'(I6,8(2X,F9.1))') JROC,ZMPL(JROC),ZBAR(JROC),ZGBR(JROC),ZGB2(JROC),& &ZOMP(JROC),ZIO (JROC),ZSER(JROC),ZMXD(JROC) ENDDO WRITE(KULOUT,'(" ")') WRITE(KULOUT,'(" ")') ENDIF ENDIF ! Trace stats IF (LTRACE_STATS) THEN WRITE(KULOUT,'(A)') '=== TRACE OF CALLS TO GSTATS' IF (NCALLS_TOTAL > NTRACE_STATS) THEN WRITE(KULOUT,'(A,2I10)') ' ONLY PART OF TRACE STORED AS BUFFER TO SMALL ',& & NCALLS_TOTAL,NTRACE_STATS ENDIF WRITE(KULOUT,'(A)') '===' CLACTION(0)='ON' CLACTION(1)='OFF' CLACTION(2)='SUSPEND' CLACTION(3)='RESUME' DO JCALL=1,MIN(NCALLS_TOTAL,NTRACE_STATS) ICALLER = MOD(NCALL_TRACE(JCALL),(JPMAXSTAT+1)) IACTION = NCALL_TRACE(JCALL)/(JPMAXSTAT+1) IF (IACTION == 0) THEN ZTIMELCALL(ICALLER) = TIME_TRACE(JCALL) ZTHISTIME(ICALLER) = 0.0_JPRD ELSEIF (IACTION == 2) THEN ZTHISTIME(ICALLER) = TIME_TRACE(JCALL)-ZTIMELCALL(ICALLER) ELSEIF (IACTION == 3) THEN ZTIMELCALL(ICALLER) = TIME_TRACE(JCALL) ENDIF IF (IACTION == 1) THEN WRITE(KULOUT,'(1X,F10.3,1X,A,1X,A,1X,F10.3)') & &TIME_TRACE(JCALL),CCDESC(ICALLER),CLACTION(IACTION),& &ZTHISTIME(ICALLER)+(TIME_TRACE(JCALL)-ZTIMELCALL(ICALLER)) ELSE WRITE(KULOUT,'(1X,F10.3,1X,A,1X,A)') TIME_TRACE(JCALL),CCDESC(ICALLER),& & CLACTION(IACTION) ENDIF ENDDO ENDIF IF(LSTATS .AND. MYPROC_STATS == 1) THEN PAVEAVE(0:KLEN) = ZAVEAVE(0:KLEN) ELSE PAVEAVE(0:KLEN) = 0.0_JPRD ENDIF WRITE(KULOUT,'(/A)')'===-=== END OF TIMING STATISTICS ===-===' IF(LSTATS_MEM)THEN IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF WRITE(KULOUT,*) '' WRITE(KULOUT,*) 'STATS FOR MEMORY' WRITE(KULOUT,*) & &' NUM ROUTINE CALLS CALL MAXINCR TOTINCR MININCR' WRITE(KULOUT,*) & &' NO (KB) (KB) (KB)' DO JNUM=0,JPMAXSTAT IF(NCALLS(JNUM) > 1) THEN ICALLS = NCALLS(JNUM)/2 IMEM=NTMEM(JNUM,1) INUM=NTMEM(JNUM,3)/2 JMEM=NTMEM(JNUM,4) WRITE(KULOUT,'(I4,1X,A20,1X,I8,1X,I6,3(1X,I9))')& &JNUM,CCDESC(JNUM),ICALLS,INUM,IMEM,JMEM,NTMEM(JNUM,5) IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A,I4,A,/,A,A20,A,/,A,I8,A,/,A,I6,A,/,3(A,I9,A,/))')& &'',& &'',CCDESC(JNUM),'',& &'',ICALLS,'',& &'',INUM,'','',IMEM,'',& &'',JMEM,'',& &'',NTMEM(JNUM,5),'' ENDIF ENDIF ENDDO WRITE(KULOUT,*) '' WRITE(KULOUT,'(/A)')'===-=== END OF MEMORY STATISTICS ===-===' WRITE(KULOUT,*) '' IF(LXML_STATS)THEN WRITE(IXMLLUN,'(A)')'' ENDIF ENDIF IF(LXML_STATS .AND. MYPROC_STATS==1)THEN WRITE(IXMLLUN,'(A)')'' CLOSE(IXMLLUN) ENDIF RETURN END SUBROUTINE GSTATS_PRINT fiat-ecmwf-2.0.0/src/fiat/gstats/gstats.F900000664000175000017500000003706515157200431020534 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS(KNUM, KSWITCH) !**** *GSTATS* - Gather timing statistics ! PURPOSE. ! -------- ! To gather timings for subsequent output by routine STATS_OUTPUT !** INTERFACE. ! ---------- ! *CALL* *GSTATS(KNUM,KSWITCH) ! EXPLICIT ARGUMENTS ! -------------------- ! KNUM - timing event number (for list of already defined events ! see routine STATS_OUTPUT) ! KSWITCH - KSWITCH=0 - switch on timer ! KSWITCH=1 - switch off timer ! KSWITCH=2 - suspend timer ! KSWITCH=3 - resume timer ! IMPLICIT ARGUMENTS ! -------------------- ! Module YOMSTATS ! METHOD. ! ------- ! EXTERNALS. USER_CLOCK - timing routine ! ---------- ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! Mats Hamrud ECMWF ! MODIFICATIONS. ! -------------- ! ORIGINAL : 98-11-15 ! D.Salmond: 02-02-25 Return if not master thread when called from a ! parallel region. ! J.Hague: 03-06-11 Memory tracing (for NSTATS_MEM MPI tasks) ! G.Mozdzynski: 18 Apr 2008 Many corrections to gstats, ! see LLFINDSUMB - when set is used detect gstat counter problems. ! G.Mozdzynski: 20 Jan 2010 Further corrections to gstats to get timed sections and ! SUMB to 100 percent of the total time. ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPRD, JPIM ,JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE YOMGSTATS, ONLY: JPMAXSTAT, LSTATS, LGSTATS_LABEL, CCDESC, CCTYPE, LSTATSCPU, TIMESUM, NCALLS, & & NSWITCHVAL, TIMESQSUM, TIMEMAX, TIMESUMB, TTCPUSUM, TVCPUSUM, TIMELCALL, & & NTMEM, TIME_LAST_CALL, JPERR, MYPROC_STATS, THISTIME, TTCPULCALL, TVCPULCALL, & & THISTCPU, THISVCPU, NSTATS_MEM, LSTATS_ALLOC, LSTATS_MPL, UNKNOWN_NUMSEND, & & UNKNOWN_NUMRECV, UNKNOWN_SENDBYTES, UNKNOWN_RECVBYTES, NUMSEND, NUMRECV, & & SENDBYTES, RECVBYTES, JPMAXDELAYS, NDELAY_INDEX, NDELAY_COUNTER, & & TDELAY_VALUE, CDELAY_TIME, LTRACE_STATS, NTRACE_STATS, NCALLS_TOTAL, & & TIME_TRACE, NCALL_TRACE, LAST_KSWITCH, LAST_KNUM USE MPL_STATS_MOD, ONLY: MPL_STATSON, MPL_STATSREAD USE OML_MOD, ONLY: OML_MY_THREAD, OML_GET_MAX_THREADS, OML_MAX_THREADS IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KNUM INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH INTEGER(KIND=JPIM) :: IMOD, ICALL INTEGER(KIND=JPIM) :: IIMEM, IIPAG, IIMEMC INTEGER(KIND=JPIB) :: IMEM, IMEMH, IMEMS, IMEMC, IPAG, INUM INTEGER(KIND=JPIB) :: GETMAXRSS, GETHWM, GETSTK, GETCURHEAP, GETPAG EXTERNAL GETMAXRSS, GETHWM, GETSTK, GETCURHEAP, GETPAG REAL(KIND=JPRD) :: ZTIMED, ZCLOCK, ZCLOCK1, ZTIME, ZTCPU, ZVCPU LOGICAL :: LLFIRST = .TRUE. LOGICAL :: LLMFIRST = .TRUE. CHARACTER(LEN=32), SAVE :: CCDESC_DRHOOK(JPMAXSTAT) CHARACTER(LEN=32), SAVE :: CCDESC_BARR(JPMAXSTAT) SAVE IIMEM, IIPAG, IIMEMC INTEGER(KIND=JPIM), SAVE :: NUM_THREADS INTEGER(KIND=JPIM) :: INUMTH ! Current value <= NUM_THREADS REAL(KIND=JPHOOK), ALLOCATABLE,SAVE :: ZHOOK_HANDLE(:) REAL(KIND=JPHOOK), SAVE :: ZHOOK_HANDLE_COMMS, ZHOOK_HANDLE_COMMS1 REAL(KIND=JPHOOK), SAVE :: ZHOOK_HANDLE_TRANS REAL(KIND=JPHOOK), SAVE :: ZHOOK_HANDLE_BARR CHARACTER*4 CC CHARACTER(LEN=10) :: CLDATEOD, CLZONEOD INTEGER(KIND=JPIM) :: IVALUES(8) ! Change LLFINDSUMB to TRUE to add diagnostics to help find SUMB times ! Note that a similar setting exists in dr_hook_util for the same objective LOGICAL :: LLFINDSUMB = .FALSE. INTEGER(KIND=JPIM), SAVE :: ISUMBSTACK(10) INTEGER(KIND=JPIM) :: J REAL(KIND=JPRD) :: SBYTES, RBYTES INTEGER(KIND=JPIM) :: NSEND, NRECV CHARACTER(LEN=4) :: CL_MAXSTAT CHARACTER(LEN=66) :: CL_ERROR_MESSAGE #include "user_clock.intfb.h" ! Process GSTATS calls if LSTATS is .TRUE. and we are the master IF (LSTATS .AND. OML_MY_THREAD() == 1) THEN IF (.NOT. ALLOCATED(ZHOOK_HANDLE)) THEN NUM_THREADS = OML_GET_MAX_THREADS() ALLOCATE(ZHOOK_HANDLE(NUM_THREADS)) ENDIF IF (LGSTATS_LABEL) THEN DO INUM = 1, JPMAXSTAT WRITE(CC,'(I4)') INUM CCDESC_BARR(INUM) = '>BAR-' // CCDESC(INUM)(1:21) // '(' // CC // ')' ENDDO DO INUM = 1, JPMAXSTAT WRITE(CC,'(I4)') INUM IF (CCTYPE(INUM) .EQ. "TRS" .OR. CCTYPE(INUM) .EQ. 'MP-' .OR. CCTYPE(INUM) .EQ. 'MPL' & & .OR. CCTYPE(INUM) .EQ. 'BAR' .OR. CCTYPE(INUM) .EQ. 'OMP') THEN CCDESC_DRHOOK(INUM) = '>' // CCTYPE(INUM) // '-' // CCDESC(INUM)(1:21) // '(' // CC // ')' ENDIF ENDDO LGSTATS_LABEL = .FALSE. ENDIF ! ------------------------------------------------------------------ CALL USER_CLOCK(PELAPSED_TIME=ZCLOCK) IF (LSTATSCPU .OR. KNUM == 0) THEN CALL USER_CLOCK(PTOTAL_CP=ZTCPU, PVECTOR_CP=ZVCPU) ELSE ZTCPU = 0.0_JPRD ZVCPU = 0.0_JPRD ENDIF IF (LLFIRST) THEN TIMESUM(:) = 0.0_JPRD NCALLS(:) = 0 ENDIF IF (LHOOK .AND. (KSWITCH == 0 .OR. KSWITCH == 1)) THEN IF (CCTYPE(KNUM) .EQ. "TRS") THEN CALL DR_HOOK(CCDESC_DRHOOK(KNUM), KSWITCH, ZHOOK_HANDLE_TRANS) ELSEIF (CCTYPE(KNUM) .EQ. 'MP-') THEN CALL DR_HOOK(CCDESC_DRHOOK(KNUM), KSWITCH, ZHOOK_HANDLE_COMMS) ELSEIF (CCTYPE(KNUM) .EQ. 'MPL' .AND. KNUM .NE. 682) THEN CALL DR_HOOK(CCDESC_DRHOOK(KNUM), KSWITCH, ZHOOK_HANDLE_COMMS1) ELSEIF (CCTYPE(KNUM) .EQ. 'OMP') THEN ! The prevailing number of threads -- could now be less than the absolute max (i.e. export ! OMP_NUM_THREADS=) INUMTH = OML_MAX_THREADS() CALL DR_HOOK(CCDESC_DRHOOK(KNUM), KSWITCH, ZHOOK_HANDLE(1:INUMTH)) ELSEIF (CCTYPE(KNUM) .EQ. 'BAR')THEN CALL DR_HOOK(CCDESC_DRHOOK(KNUM), KSWITCH, ZHOOK_HANDLE_BARR) ENDIF ! Measure GSTATS HOOK overhead CALL USER_CLOCK(PELAPSED_TIME=ZCLOCK1) TIMESUM(401) = TIMESUM(401) + ZCLOCK1 - ZCLOCK NCALLS(401) = NCALLS(401) + 1 ZCLOCK = ZCLOCK1 ENDIF IF (LLFIRST) THEN NSWITCHVAL(:) = -1 TIMESQSUM(:) = 0.0_JPRD TIMEMAX(:) = 0.0_JPRD TIMESUMB(:) = 0.0_JPRD IF (LLFINDSUMB) THEN ISUMBSTACK(:) = 0 ENDIF TTCPUSUM(:) = 0.0_JPRD TVCPUSUM(:) = 0.0_JPRD TIMELCALL(:) = ZCLOCK NTMEM = 0 NTMEM(:,5) = 99999999 IIMEM = 0 IIPAG = 0 IIMEMC = 0 TIME_LAST_CALL = ZCLOCK LLFIRST = .FALSE. ENDIF ! Check KNUM is valid (> 0 and < JPMAXSTAT) IF (KNUM < 0) CALL ABOR1('GSTATS: KNUM cannot be negative') IF (KNUM > JPMAXSTAT) THEN WRITE(CL_MAXSTAT,'(I4)') JPMAXSTAT CALL ABOR1('GSTATS: KNUM cannot be greater than ' // CL_MAXSTAT) ENDIF IF (KSWITCH == 0 .OR. KSWITCH == 1) THEN NCALLS(KNUM) = NCALLS(KNUM) + 1 ENDIF IMOD = MOD(NCALLS(KNUM), 2) ! Check we haven't opened or closed a region twice in a row IF (.NOT.((KSWITCH == 0 .AND. IMOD == 1) .OR. (KSWITCH == 2 .AND. IMOD == 1) .OR. & & (KSWITCH == 3 .AND. IMOD == 1) .OR. (KSWITCH == 1 .AND. IMOD == 0))) THEN WRITE(CL_ERROR_MESSAGE,'(A42,I4)') "Invalid GSTATS call - check region KNUM = ", KNUM CALL ABOR1('GSTATS: ' // CL_ERROR_MESSAGE) ENDIF NSWITCHVAL(KNUM) = KSWITCH IF (KSWITCH == 0) THEN ! Start timing event IF (KNUM >= 500) THEN ZTIMED = ZCLOCK - TIME_LAST_CALL TIMESUMB(KNUM) = TIMESUMB(KNUM) + ZTIMED ELSE ZTIMED = 0.0_JPRD ENDIF IF (LLFINDSUMB .AND. MYPROC_STATS <= 2)THEN ! Diagnostic code to find source of sumb (this should only be activated temporarily) DO J = 9, 1, -1 ISUMBSTACK(J+1) = ISUMBSTACK(J) ENDDO ISUMBSTACK(1) = KNUM IF (ZTIMED > 0.1_JPRD .AND. (TIMESUMB(KNUM) > 1.0_JPRD)) THEN WRITE(0,'("GSTATS(SUMB): KNUM=",I4," ZTIMED=",F10.6," TIMESUMB=",F10.6)') & & KNUM, ZTIMED, TIMESUMB(KNUM) DO J = 1, 10 IF (ISUMBSTACK(J) > 0) THEN WRITE(0,'("GSTATS(SUMB): ",I4,2X,I8,2X,A40)') ISUMBSTACK(J), NCALLS(ISUMBSTACK(J)), & & CCDESC(ISUMBSTACK(J)) ENDIF ENDDO ENDIF ! Check if grouped counters are overlapping DO J = 0, JPMAXSTAT IF (J /= KNUM)THEN IF (CCTYPE(J ) /= ' ' .AND. CCTYPE(J ) /= 'TRS' .AND. CCTYPE(J ) /= 'MP-' .AND. & & CCTYPE(KNUM) /= ' ' .AND. CCTYPE(KNUM) /= 'TRS' .AND. CCTYPE(KNUM) /= 'MP-') THEN IF (NSWITCHVAL(J) == 0 .OR. NSWITCHVAL(J) == 3) THEN WRITE(0,'("GSTATS(SUMB): OVERLAPPING COUNTERS ",I4,2X,I4)') KNUM, J ENDIF ENDIF ENDIF ENDDO ENDIF THISTIME(KNUM) = 0.0_JPRD TIMELCALL(KNUM) = ZCLOCK TTCPULCALL(KNUM) = ZTCPU TVCPULCALL(KNUM) = ZVCPU THISTCPU(KNUM) = 0.0_JPRD THISVCPU(KNUM) = 0.0_JPRD IF (MYPROC_STATS .LE. NSTATS_MEM .AND. MYPROC_STATS .NE. 0) THEN IMEM = GETMAXRSS() / 1024 IPAG = GETPAG() IMEMH = GETHWM() / 1024 IMEMS = GETSTK() / 1024 IMEMC = 0 IF (LSTATS_ALLOC) IMEMC = GETCURHEAP() / 1024 IF (IMEM > IIMEM .OR. IPAG > IIPAG .OR. (LSTATS_ALLOC .AND. (IMEMC .NE. IIMEMC))) THEN IF (LLMFIRST) THEN WRITE(0,*) ".---------------------------------------------------------" WRITE(0,*) "| Memory trace details" WRITE(0,*) "| --------------------" WRITE(0,*) "| Memory examined at each GSTATS call if NSTATS_MEM>0." WRITE(0,*) "| Header for each trace line is:" WRITE(0,*) "|" WRITE(0,*) "| RSS_INC: Increase in RSS_MAX (KB)" WRITE(0,*) "| RSS_MAX: Maximum real working set so far (KB)" WRITE(0,*) "| HEAP_MX: High Water Mark for heap so far (KB)" WRITE(0,*) "| STK: Current Stack usage (KB)" WRITE(0,*) "| PGS: Page faults w I/O since last trace line" WRITE(0,*) "| CALL: Number of gstats call" WRITE(0,*) "| HEAP: Current malloc'd total (KB)" WRITE(0,*) "|" WRITE(0,*) "| Trace line written for NSTATS_MEM MPI tasks if RSS_MAX" WRITE(0,*) "| RSS_MAX increases, PGS>0, or HEAP changed" WRITE(0,*) "| (if LTATS_ALLOC=.TRUE.)" WRITE(0,*) "`---------------------------------------------------------" WRITE(0,*) "" WRITE(0,'(A10,A5,21X,A7,2A8,A7,A5,A5,A8)') & & "MEMORY "," KNUM","RSS_INC"," RSS_MAX"," HEAP_MX"," STK", & & " PGS"," CALL"," HEAP" LLMFIRST = .FALSE. ENDIF WRITE(0,'(A10,I5,1X,A20,1X,I6,2(1X,I7),1X,I6,1X,I4,1X,I4,1X,I7)') & & "MEMORY bfr", KNUM, CCDESC(KNUM), IMEM - IIMEM, IMEM, IMEMH, IMEMS, IPAG - IIPAG, & & (NCALLS(KNUM) + 1) / 2, IMEMC ENDIF NTMEM(KNUM,2) = IMEM IIMEM = IMEM IIPAG = IPAG IIMEMC = IMEMC ENDIF IF (LSTATS_MPL .AND. CCTYPE(KNUM) .EQ. 'MPL') THEN CALL MPL_STATSON(NSEND, SBYTES, NRECV, RBYTES) UNKNOWN_NUMSEND(KNUM) = UNKNOWN_NUMSEND(KNUM) + NSEND UNKNOWN_NUMRECV(KNUM) = UNKNOWN_NUMRECV(KNUM) + NRECV UNKNOWN_SENDBYTES(KNUM) = UNKNOWN_SENDBYTES(KNUM) + SBYTES UNKNOWN_RECVBYTES(KNUM) = UNKNOWN_RECVBYTES(KNUM) + RBYTES ENDIF ELSEIF (KSWITCH == 1) THEN ! Finish timing event ZTIME = THISTIME(KNUM) + (ZCLOCK - TIMELCALL(KNUM)) IF (LSTATS_MPL .AND. CCTYPE(KNUM) .EQ. 'MPL') THEN CALL MPL_STATSREAD(NSEND, SBYTES, NRECV, RBYTES) NUMSEND(KNUM) = NUMSEND(KNUM) + NSEND NUMRECV(KNUM) = NUMRECV(KNUM) + NRECV SENDBYTES(KNUM) = SENDBYTES(KNUM) + SBYTES RECVBYTES(KNUM) = RECVBYTES(KNUM) + RBYTES ENDIF TIMESUM(KNUM) = TIMESUM(KNUM) + ZTIME TIMESQSUM(KNUM) = TIMESQSUM(KNUM) + ZTIME ** 2 TIMEMAX(KNUM) = MAX(TIMEMAX(KNUM), ZTIME) TTCPUSUM(KNUM) = TTCPUSUM(KNUM) + THISTCPU(KNUM) + ZTCPU - TTCPULCALL(KNUM) TVCPUSUM(KNUM) = TVCPUSUM(KNUM) + THISVCPU(KNUM) + ZVCPU - TVCPULCALL(KNUM) IF (MYPROC_STATS .LE. NSTATS_MEM .AND. MYPROC_STATS .NE. 0) THEN IMEM = GETMAXRSS() / 1024 IPAG = GETPAG() IMEMH = GETHWM() / 1024 IMEMS = GETSTK() / 1024 IMEMC = 0 IF (LSTATS_ALLOC) IMEMC = GETCURHEAP() / 1024 IF (IMEM > IIMEM .OR. IPAG > IIPAG .OR. (LSTATS_ALLOC .AND. (IMEMC .NE. IIMEMC))) THEN WRITE(0,'(A10,I5,1X,A20,1X,I6,2(1X,I7),1X,I6,1X,I4,1X,I4,1X,I7)') & & "MEMORY aft ", KNUM, CCDESC(KNUM), IMEM - IIMEM, IMEM, IMEMH, IMEMS, IPAG - IIPAG, & & NCALLS(KNUM) / 2, IMEMC ENDIF IIMEM = IMEM IIPAG = IPAG IIMEMC = IMEMC IMEM = IMEM - NTMEM(KNUM, 2) NTMEM(KNUM,4) = NTMEM(KNUM, 4) + IMEM IF (IMEM > NTMEM(KNUM,1)) THEN NTMEM(KNUM,1) = IMEM NTMEM(KNUM,3) = NCALLS(KNUM) ENDIF IF (IMEM < NTMEM(KNUM,5)) NTMEM(KNUM,5) = IMEM ENDIF ! Save counters that result in large delays IF (KNUM >= 500 .AND. NCALLS(KNUM) / 2 > 10)THEN IF (ZTIME > TIMESUM(KNUM) / FLOAT(NCALLS(KNUM)/2) + 0.2_JPRD) THEN ! Ignore counters 1007 and 1013 due to NFRLW frequency LW radiation calls ! in ec_phys_tl and ec_phys_ad call trees ! also ignore 635 and 636 due to increasing sujbwavallo matrix sizes IF (KNUM /= 1007 .AND. KNUM /= 1013 .AND. KNUM /= 635 .AND. KNUM /= 636 ) THEN IF (NDELAY_INDEX < JPMAXDELAYS) THEN NDELAY_INDEX = NDELAY_INDEX + 1 NDELAY_COUNTER(NDELAY_INDEX) = KNUM TDELAY_VALUE(NDELAY_INDEX) = ZTIME - TIMESUM(KNUM) / FLOAT(NCALLS(KNUM) / 2) CALL DATE_AND_TIME(CLDATEOD, CDELAY_TIME(NDELAY_INDEX), CLZONEOD, IVALUES) ENDIF ENDIF ENDIF ENDIF ELSEIF (KSWITCH == 2) THEN ! Suspend timing event ZTIMED = ZCLOCK - TIMELCALL(KNUM) THISTIME(KNUM) = THISTIME(KNUM) + ZTIMED THISTCPU(KNUM) = THISTCPU(KNUM) + ZTCPU - TTCPULCALL(KNUM) THISVCPU(KNUM) = THISVCPU(KNUM) + ZVCPU - TVCPULCALL(KNUM) IF (LSTATS_MPL .AND. CCTYPE(KNUM) .EQ. 'MPL') THEN CALL MPL_STATSREAD(NSEND, SBYTES, NRECV, RBYTES) NUMSEND(KNUM) = NUMSEND(KNUM) + NSEND NUMRECV(KNUM) = NUMRECV(KNUM) + NRECV SENDBYTES(KNUM) = SENDBYTES(KNUM) + SBYTES RECVBYTES(KNUM) = RECVBYTES(KNUM) + RBYTES ENDIF ELSEIF (KSWITCH == 3) THEN ! Resume timing event TIMELCALL(KNUM) = ZCLOCK TTCPULCALL(KNUM) = ZTCPU TVCPULCALL(KNUM) = ZVCPU IF (LSTATS_MPL .AND. CCTYPE(KNUM) .EQ. 'MPL') THEN CALL MPL_STATSON(NSEND, SBYTES, NRECV, RBYTES) UNKNOWN_NUMSEND(KNUM) = UNKNOWN_NUMSEND(KNUM) + NSEND UNKNOWN_NUMRECV(KNUM) = UNKNOWN_NUMRECV(KNUM) + NRECV UNKNOWN_SENDBYTES(KNUM) = UNKNOWN_SENDBYTES(KNUM) + SBYTES UNKNOWN_RECVBYTES(KNUM) = UNKNOWN_RECVBYTES(KNUM) + RBYTES ENDIF IF (KNUM >= 500) THEN ZTIMED = ZCLOCK - TIME_LAST_CALL TIMESUMB(KNUM) = TIMESUMB(KNUM) + ZTIMED ENDIF ENDIF IF (KNUM >= 500) THEN TIME_LAST_CALL = ZCLOCK ENDIF ! Trace stats NCALLS_TOTAL = NCALLS_TOTAL + 1 IF (LTRACE_STATS .AND. NCALLS_TOTAL <= NTRACE_STATS) THEN ICALL = NCALLS_TOTAL TIME_TRACE(ICALL) = ZCLOCK NCALL_TRACE(ICALL) = (JPMAXSTAT+1) * KSWITCH + KNUM ENDIF ! Measure gstats overhead CALL USER_CLOCK(PELAPSED_TIME=ZCLOCK1) TIMESUM(400) = TIMESUM(400) + ZCLOCK1 - ZCLOCK NCALLS(400) = NCALLS(400) + 1 LAST_KSWITCH = KSWITCH LAST_KNUM = KNUM ENDIF END SUBROUTINE GSTATS fiat-ecmwf-2.0.0/src/fiat/gstats/gstats_query.F900000664000175000017500000000302315157200431021744 0ustar alastairalastairSUBROUTINE GSTATS_QUERY(KNUM,PTIME) !**** *GSTATS_QUERY* - Get current value of gstats timer ! PURPOSE. ! -------- ! To query values of gstats timer for use in live output !** INTERFACE. ! ---------- ! *CALL* *GSTATS(KNUM,PTIME) ! EXPLICIT ARGUMENTS ! -------------------- ! KNUM - timing event number (for list of already defined events ! see routine STATS_OUTPUT) ! PTIME - Output current value of timer ! IMPLICIT ARGUMENTS ! -------------------- ! Module YOMGSTATS ! METHOD. ! ------- ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! P. Gillies ECMWF ! MODIFICATIONS. ! -------------- ! ORIGINAL : 2021-03-03 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE YOMGSTATS USE OML_MOD IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUM REAL(KIND=JPRD),INTENT(OUT) :: PTIME REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('GSTATS_QUERY',0,ZHOOK_HANDLE) IF(LSTATS) THEN ! only process gstats calls for master thread IF(OML_MY_THREAD() <= 1) THEN ! Return current total value of specified timer IF(NCALLS(KNUM)>1) THEN PTIME=TIMESUM(KNUM) ELSE PTIME=0.0_JPRD ENDIF ENDIF ELSE PTIME=0.0_JPRD ENDIF IF (LHOOK) CALL DR_HOOK('GSTATS_QUERY',1,ZHOOK_HANDLE) END SUBROUTINE GSTATS_QUERY fiat-ecmwf-2.0.0/src/fiat/gstats/yomgstats.F900000664000175000017500000001256115157200431021253 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE YOMGSTATS USE EC_PARKIND, ONLY: JPRD, JPIM IMPLICIT NONE SAVE PRIVATE :: JPRD, JPIM ! ------------------------------------------------------------------ ! Module for timing statistics. Module is internal to the GSTATS package - ! routines GSTATS, SUSTATS and STATS_OUTPUT. The logical switches are ! re-initialized in SUMPINI ! LSTATS - TRUE for gathering timing statistics ! LSTATSCPU - TRUE for gathering CPU timing statistics ! LSYNCSTATS - TRUE for syncronization (call to barrier) at the ! start of timing event ! LDETAILED_STATS - TRUE for more detail in output ! LXML_STATS - TRUE for stats output in XML ! LCSV_STATS - TRUE for stats output in CSV per rank ! LSTATS_OMP - TRUE for gathering timing statistics on OpenMP regions ! 1001-1999 ! LSTATS_COMMS - TRUE for gathering detailed timing of Message passing ! 501-1000 ! LSTATS_MPL - TRUE for gathering detailed info on message passing ! NTRACE_STATS - max number of entries in trace ! LTRACE_STATS - True for trace of all calls to gstats ! LGSTATS_LABEL - True after GSTATS-labels have been set ! JPMAXSTAT - max number of separate timers in gstats ! JPOBCOUNT_BASE - first counter for obs types ! NCALLS - number of times a timer has been switched on ! TIMESUM - total time spent with timer on ! TIMESQSUM - sum of the squares of times ! TIMEMAX - max time of all calls ! TIMESUMB - sum of times between previous timer was invoked and this ! timer was switched on ( to be used for finding out which parts ! of the code that is not being timed) ! TIMELCALL - time when event was switched on or resumed ! TTCPUSUM - total cpu time ! TVCPUSUM - total vector cpu time ! THISTIME - total accumulated time for this call to timing event (necessary ! to be able to suspend and resume timer and still have it counted ! as one timing event) ! THISTCPU - as THISTIME but for CPU time ! THISVCPU - as THISTIME but for vector CPU time ! TTCPULCALL - as TIMELCALL but for CPU time ! TVCPULCALL - as TIMELCALL but for vector CPU time ! TIME_LAST_CALL - last time GSTATS was called ! TIME_START - used for recording parallel startup time ! ! NSWITCHVAL - for detecting overlapping counters LOGICAL :: LSTATS = .TRUE. LOGICAL :: LSTATS_OMP = .FALSE. LOGICAL :: LSTATS_COMMS = .FALSE. LOGICAL :: LSTATS_MPL = .FALSE. LOGICAL :: LSTATS_MEM = .FALSE. LOGICAL :: LSTATS_ALLOC = .FALSE. LOGICAL :: LSTATSCPU = .TRUE. LOGICAL :: LSYNCSTATS = .FALSE. LOGICAL :: LXML_STATS = .FALSE. LOGICAL :: LCSV_STATS = .FALSE. LOGICAL :: LDETAILED_STATS = .TRUE. LOGICAL :: LBARRIER_STATS = .FALSE. LOGICAL :: LBARRIER_STATS2 = .FALSE. LOGICAL :: LTRACE_STATS = .FALSE. LOGICAL :: LGSTATS_LABEL = .FALSE. INTEGER(KIND=JPIM),PARAMETER :: JBMAXBASE=2500 INTEGER(KIND=JPIM),PARAMETER :: JPMAXBARS=500 INTEGER(KIND=JPIM),PARAMETER :: JPMAXSTAT=JBMAXBASE+JPMAXBARS INTEGER(KIND=JPIM),PARAMETER :: JPOBCOUNT_BASE=201 INTEGER(KIND=JPIM) :: NTRACE_STATS=0 INTEGER(KIND=JPIM) :: NCALLS(0:JPMAXSTAT) INTEGER(KIND=JPIM) :: NSWITCHVAL(0:JPMAXSTAT) INTEGER(KIND=JPIM) :: NCALLS_TOTAL=0 INTEGER(KIND=JPIM) :: LAST_KSWITCH=0 INTEGER(KIND=JPIM) :: LAST_KNUM=0 INTEGER(KIND=JPIM) :: NHOOK_MESSAGES=0 INTEGER(KIND=JPIM) :: NBAR_PTR(0:JPMAXSTAT)=0 INTEGER(KIND=JPIM) :: NBAR2=JBMAXBASE+1 INTEGER(KIND=JPIM),ALLOCATABLE :: NCALL_TRACE(:) INTEGER(KIND=JPIM),ALLOCATABLE :: NUMSEND(:) INTEGER(KIND=JPIM),ALLOCATABLE :: NUMRECV(:) REAL(KIND=JPRD),ALLOCATABLE :: SENDBYTES(:) REAL(KIND=JPRD),ALLOCATABLE :: RECVBYTES(:) INTEGER(KIND=JPIM),ALLOCATABLE :: UNKNOWN_NUMSEND(:) INTEGER(KIND=JPIM),ALLOCATABLE :: UNKNOWN_NUMRECV(:) REAL(KIND=JPRD),ALLOCATABLE :: UNKNOWN_SENDBYTES(:) REAL(KIND=JPRD),ALLOCATABLE :: UNKNOWN_RECVBYTES(:) REAL(KIND=JPRD) :: TIMESUM(0:JPMAXSTAT) REAL(KIND=JPRD) :: TIMESQSUM(0:JPMAXSTAT) REAL(KIND=JPRD) :: TIMEMAX(0:JPMAXSTAT) REAL(KIND=JPRD) :: TIMESUMB(0:JPMAXSTAT) REAL(KIND=JPRD) :: TIMELCALL(0:JPMAXSTAT) REAL(KIND=JPRD) :: TTCPUSUM(0:JPMAXSTAT) REAL(KIND=JPRD) :: TVCPUSUM(0:JPMAXSTAT) REAL(KIND=JPRD) :: THISTIME(0:JPMAXSTAT) REAL(KIND=JPRD) :: THISTCPU(0:JPMAXSTAT) REAL(KIND=JPRD) :: THISVCPU(0:JPMAXSTAT) REAL(KIND=JPRD) :: TTCPULCALL(0:JPMAXSTAT) REAL(KIND=JPRD) :: TVCPULCALL(0:JPMAXSTAT) REAL(KIND=JPRD) :: TIME_LAST_CALL REAL(KIND=JPRD),ALLOCATABLE :: TIME_START(:) REAL(KIND=JPRD),ALLOCATABLE :: TIME_TRACE(:) INTEGER(KIND=JPIM),PARAMETER :: JPERR=0 INTEGER(KIND=JPIM),PARAMETER :: JPTAGSTAT=20555 INTEGER(KIND=JPIM),PARAMETER :: JPMAXDELAYS=1000 INTEGER(KIND=JPIM) :: NDELAY_COUNTER(1:JPMAXDELAYS) REAL(KIND=JPRD) :: TDELAY_VALUE(1:JPMAXDELAYS) CHARACTER(LEN=10) :: CDELAY_TIME(1:JPMAXDELAYS) INTEGER(KIND=JPIM) :: NDELAY_INDEX = 0 CHARACTER(LEN=50) :: CCDESC(0:JPMAXSTAT) = "" CHARACTER(LEN=3) :: CCTYPE(0:JPMAXSTAT) = "" INTEGER(KIND=JPIM) :: NPROC_STATS = 1 INTEGER(KIND=JPIM) :: MYPROC_STATS = 1 INTEGER(KIND=JPIM),ALLOCATABLE :: NPRCIDS_STATS(:) INTEGER(KIND=JPIM) :: NTMEM(0:JPMAXSTAT,5) INTEGER(KIND=JPIM) :: NSTATS_MEM=0 INTEGER(KIND=JPIM) :: NPRNT_STATS=3 END MODULE YOMGSTATS fiat-ecmwf-2.0.0/src/fiat/gstats/gstats_barrier.F900000664000175000017500000000132115157200431022224 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS_BARRIER(KNUM) USE EC_PARKIND, ONLY: JPIM USE YOMGSTATS, ONLY: LBARRIER_STATS USE MPL_MODULE, ONLY: MPL_BARRIER IMPLICIT NONE INTEGER(KIND=JPIM) :: KNUM IF (LBARRIER_STATS) THEN CALL GSTATS(KNUM, 0) CALL MPL_BARRIER() CALL GSTATS(KNUM, 1) ENDIF END SUBROUTINE GSTATS_BARRIER fiat-ecmwf-2.0.0/src/fiat/gstats/gstats_setup.F900000664000175000017500000001016315157200431021742 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GSTATS_SETUP( KPROC,KMYPROC,KPRCIDS,& & LDSTATS,LDSTATSCPU,LDSYNCSTATS,LDDETAILED_STATS,LDBARRIER_STATS,LDBARRIER_STATS2,& & LDSTATS_OMP,LDSTATS_COMMS,LDSTATS_MEM,KSTATS_MEM,LDSTATS_ALLOC,& & LDTRACE_STATS,KTRACE_STATS,KPRNT_STATS,LDXML_STATS,LDCSV_STATS) !**** *GSTATS_SETUP* - Setup stats package ! PURPOSE. ! -------- ! Setup gstats package !** INTERFACE. ! ---------- ! *CALL* *GSTATS_SETUP ! EXPLICIT ARGUMENTS None ! -------------------- ! IMPLICIT ARGUMENTS ! -------------------- ! Module YOMSTATS ! METHOD. ! ------- ! EXTERNALS. USER_CLOCK - timing routine ! ---------- ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! Mats Hamrud ECMWF ! MODIFICATIONS. ! -------------- ! ORIGINAL : 98-11-15 ! I. Hadade 19-05-20 Removed LDSTATS_MPL as not used and enabled collection ! of MPL send/recv statistics if LDETAILED_STATS is true ! rather than LBARRIER_STATS ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPIM, JPRD USE YOMGSTATS, ONLY: LSTATS, LSTATSCPU, LSYNCSTATS, LDETAILED_STATS, LBARRIER_STATS, & & LBARRIER_STATS2, LXML_STATS, LCSV_STATS, LSTATS_OMP, LSTATS_COMMS, NSTATS_MEM, & & LSTATS_MEM, LSTATS_ALLOC, LTRACE_STATS, NTRACE_STATS, MYPROC_STATS, & & NPROC_STATS, NPRCIDS_STATS, NCALL_TRACE, TIME_TRACE, LSTATS_MPL, NUMSEND, & & NUMRECV, SENDBYTES, RECVBYTES, UNKNOWN_NUMSEND, UNKNOWN_NUMRECV, & & UNKNOWN_SENDBYTES, UNKNOWN_RECVBYTES, NPRNT_STATS USE MPL_STATS_MOD, ONLY: MPL_STATSINIT IMPLICIT NONE LOGICAL :: LDSTATS LOGICAL :: LDSTATSCPU LOGICAL :: LDSYNCSTATS LOGICAL :: LDDETAILED_STATS LOGICAL :: LDBARRIER_STATS LOGICAL :: LDBARRIER_STATS2 LOGICAL :: LDSTATS_OMP LOGICAL :: LDSTATS_COMMS LOGICAL :: LDTRACE_STATS INTEGER(KIND=JPIM) :: KTRACE_STATS INTEGER(KIND=JPIM) :: KPROC,KMYPROC INTEGER(KIND=JPIM) :: KPRCIDS(KPROC) INTEGER(KIND=JPIM) :: KSTATS_MEM INTEGER(KIND=JPIM) :: KPRNT_STATS LOGICAL :: LDSTATS_MEM LOGICAL :: LDSTATS_ALLOC LOGICAL :: LDXML_STATS LOGICAL, OPTIONAL :: LDCSV_STATS ! ------------------------------------------------------------------ LSTATS = LDSTATS LSTATSCPU = LDSTATSCPU LSYNCSTATS = LDSYNCSTATS LDETAILED_STATS = LDDETAILED_STATS LBARRIER_STATS = LDBARRIER_STATS LBARRIER_STATS2 = LDBARRIER_STATS2 LXML_STATS = LDXML_STATS IF (PRESENT(LDCSV_STATS)) LCSV_STATS = LDCSV_STATS LSTATS_OMP = LDSTATS_OMP LSTATS_COMMS = LDSTATS_COMMS NSTATS_MEM = KSTATS_MEM LSTATS_MEM = LDSTATS_MEM LSTATS_ALLOC = LDSTATS_ALLOC LTRACE_STATS = LDTRACE_STATS IF (LTRACE_STATS) NTRACE_STATS = KTRACE_STATS MYPROC_STATS = KMYPROC NPROC_STATS = KPROC ALLOCATE(NPRCIDS_STATS(NPROC_STATS)) NPRCIDS_STATS(:) = KPRCIDS(1:NPROC_STATS) IF (NPROC_STATS == 1) LSYNCSTATS = .FALSE. IF (LTRACE_STATS .AND. NTRACE_STATS > 0) THEN ALLOCATE(NCALL_TRACE(NTRACE_STATS)) ALLOCATE(TIME_TRACE (NTRACE_STATS)) NCALL_TRACE(:) = 0 TIME_TRACE (:) = 0.0_JPRD ENDIF IF (LDETAILED_STATS) THEN LSTATS_MPL = .TRUE. ALLOCATE(NUMSEND(501:1000)) ALLOCATE(NUMRECV(501:1000)) ALLOCATE(SENDBYTES(501:1000)) ALLOCATE(RECVBYTES(501:1000)) ALLOCATE(UNKNOWN_NUMSEND(501:1000)) ALLOCATE(UNKNOWN_NUMRECV(501:1000)) ALLOCATE(UNKNOWN_SENDBYTES(501:1000)) ALLOCATE(UNKNOWN_RECVBYTES(501:1000)) NUMSEND(:) = 0 NUMRECV(:) = 0 SENDBYTES(:) = 0 RECVBYTES(:) = 0 UNKNOWN_NUMSEND(:) = 0 UNKNOWN_NUMRECV(:) = 0 UNKNOWN_SENDBYTES(:) = 0 UNKNOWN_RECVBYTES(:) = 0 CALL MPL_STATSINIT ENDIF NPRNT_STATS = KPRNT_STATS END SUBROUTINE GSTATS_SETUP fiat-ecmwf-2.0.0/src/fiat/mpl/0000775000175000017500000000000015157200431016217 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/mpl/mpl_bindc.F900000664000175000017500000000650415157200431020433 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! !! C bindings to the MPI and MPL routines !! Please include "mpl.h" for the C interfaces FUNCTION FORTRAN_MPI_ABORT(KRC) BIND(C,NAME="fortran_mpi_abort") RESULT(IRET) USE MPL_MPI, ONLY : MPI_COMM_WORLD IMPLICIT NONE INTEGER,INTENT(IN),VALUE :: KRC INTEGER :: IRET CALL MPI_ABORT(MPI_COMM_WORLD,KRC,IRET) END FUNCTION FORTRAN_MPI_ABORT FUNCTION FORTRAN_MPI_INITIALIZED() BIND(C,NAME="fortran_mpi_initialized") RESULT(IRET) IMPLICIT NONE INTEGER :: IRET INTEGER :: IERROR LOGICAL :: LINIT CALL MPI_INITIALIZED(LINIT,IERROR) IF (LINIT) THEN IRET = 1 ELSE IRET = 0 ENDIF END FUNCTION FORTRAN_MPI_INITIALIZED FUNCTION MPL_INIT_BINDC() BIND(C,NAME="mpl_init") RESULT(KERROR) USE ISO_C_BINDING, ONLY : C_INT USE MPL_MODULE, ONLY : MPL_INIT IMPLICIT NONE INTEGER(KIND=C_INT) :: KERROR CALL MPL_INIT(KERROR=KERROR,LDINFO=.FALSE.) END FUNCTION MPL_INIT_BINDC FUNCTION MPL_END_BINDC() BIND(C,NAME="mpl_end") RESULT(KERROR) USE ISO_C_BINDING, ONLY : C_INT USE MPL_MODULE, ONLY : MPL_END IMPLICIT NONE INTEGER(KIND=C_INT) :: KERROR CALL MPL_END(KERROR=KERROR) END FUNCTION MPL_END_BINDC FUNCTION MPL_MYRANK_BINDC() BIND(C,NAME="mpl_myrank") RESULT(MYRANK) USE ISO_C_BINDING, ONLY : C_INT USE MPL_MODULE, ONLY : MPL_MYRANK IMPLICIT NONE INTEGER(KIND=C_INT) :: MYRANK MYRANK = MPL_MYRANK() END FUNCTION FUNCTION MPL_COMM_BINDC() BIND(C,NAME="mpl_comm") RESULT(NCOMM) USE ISO_C_BINDING, ONLY : C_INT USE MPL_MODULE, ONLY : MPL_COMM IMPLICIT NONE INTEGER(KIND=C_INT) :: NCOMM NCOMM = MPL_COMM END FUNCTION FUNCTION MPL_COMM_OML_BINDC(OML_THREAD) BIND(C,NAME="mpl_comm_oml") RESULT(NCOMM) USE ISO_C_BINDING, ONLY : C_INT USE MPL_MODULE, ONLY : MPL_COMM_OML IMPLICIT NONE INTEGER(KIND=C_INT) :: NCOMM INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: OML_THREAD NCOMM = MPL_COMM_OML(OML_THREAD) END FUNCTION ! SUBROUTINE CMPL_ABORT(CDMESS) ! USE MPL_MODULE ! IMPLICIT NONE ! CHARACTER(LEN=*) CDMESS ! CALL MPL_ABORT(CDMESS) ! END SUBROUTINE CMPL_ABORT ! FUNCTION CMPL_NPROC() ! USE MPL_MODULE ! IMPLICIT NONE ! INTEGER CMPL_NPROC ! CMPL_NPROC=MPL_NPROC() ! END FUNCTION CMPL_NPROC ! FUNCTION CMPL_MYRANK() ! USE MPL_MODULE ! IMPLICIT NONE ! INTEGER CMPL_MYRANK ! CMPL_MYRANK=MPL_MYRANK() ! END FUNCTION CMPL_MYRANK ! SUBROUTINE CMPL_BARRIER(KERROR) ! USE MPL_MODULE ! IMPLICIT NONE ! INTEGER KERROR ! CALL MPL_BARRIER(KERROR=KERROR) ! END SUBROUTINE CMPL_BARRIER ! SUBROUTINE CMPL_END(KERROR) ! USE MPL_MODULE ! IMPLICIT NONE ! INTEGER KERROR ! CALL MPL_END(KERROR=KERROR) ! END SUBROUTINE CMPL_END ! SUBROUTINE CMPL_GETARG(KARGNO, CDARG) ! USE MPL_MODULE ! IMPLICIT NONE ! INTEGER KARGNO ! CHARACTER(LEN=*) CDARG ! CALL MPL_GETARG(KARGNO, CDARG) ! END SUBROUTINE CMPL_GETARG ! FUNCTION CMPL_IARGC() ! USE MPL_MODULE ! IMPLICIT NONE ! INTEGER CMPL_IARGC ! CMPL_IARGC = MPL_IARGC() ! END FUNCTION CMPL_IARGC fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/0000775000175000017500000000000015157200431020510 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_comm_compare_mod.F900000664000175000017500000000277715157200431025155 0ustar alastairalastair! (C) Copyright 2023- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_COMPARE_MOD !**** *MPL_COMM_COMPARE_MOD* - Compare two communicators ! Author. ! ------- ! Willem Deconinck *ECMWF* ! Original : 31-08-2023 USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_IDENT, MPI_CONGRUENT, MPI_SIMILAR IMPLICIT NONE PRIVATE PUBLIC :: MPL_COMM_COMPARE CONTAINS SUBROUTINE MPL_COMM_COMPARE (KCOMM1, KCOMM2, KRES, KERR, CDSTRING) INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM1 INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM2 INTEGER (KIND=JPIM), INTENT (OUT) :: KRES INTEGER (KIND=JPIM), INTENT (OUT) :: KERR CHARACTER (LEN=*), INTENT (IN), OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM1, ICOMM2 ICOMM1%MPI_VAL = KCOMM1 ICOMM2%MPI_VAL = KCOMM2 CALL MPI_COMM_COMPARE (ICOMM1, ICOMM2, KRES, KERR) if( KRES == MPI_IDENT ) THEN KRES = 0 ! contexts and groups are the same ELSEIF (KRES == MPI_CONGRUENT) THEN KRES = 1 ! different contexts but identical groups ELSEIF (KRES == MPI_SIMILAR) THEN KRES = 2 ! different contexts but similar groups ELSE ! (KRES == MPI_UNEQUAL) THEN KRES = 3 ! otherwise ENDIF END SUBROUTINE MPL_COMM_COMPARE END MODULE MPL_COMM_COMPARE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_locomm_create_mod.F900000664000175000017500000000542115157200431025312 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_LOCOMM_CREATE_MOD !**** MPL_LOCOMM_CREATE Create a new communicator ! Purpose. ! -------- ! Create a new communicator from lowest N tasks in MPI_COMM_WORLD ! and set as default !** Interface. ! ---------- ! CALL MPL_LOCOMM_CREATE ! Input required arguments : ! ------------------------- ! N - Number of tasks in New Communicator ! Input optional arguments : ! ------------------------- ! Output required arguments : ! ------------------------- ! KCOMM - New Communicator ! Output optional arguments : ! ------------------------- ! MPL_LOCOMM_CREATE aborts when an error is detected. ! Author. ! ------- ! J.Hague ! Modifications. ! -------------- ! Original: 21/07/2003 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_GROUP, MPI_COMM, MPI_COMM_CREATE, MPI_COMM_GROUP USE MPL_DATA_MODULE, ONLY : MPL_COMM USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_LOCOMM_CREATE CONTAINS SUBROUTINE MPL_LOCOMM_CREATE(N,KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_GROUP => MPI_COMM_GROUP8, MPI_GROUP_INCL => MPI_GROUP_INCL8, MPI_COMM_CREATE => MPI_COMM_CREATE8 #endif INTEGER(KIND=JPIM),INTENT(OUT) :: KCOMM INTEGER(KIND=JPIM),INTENT(IN) :: N INTEGER(KIND=JPIM) :: IRANK(N) INTEGER(KIND=JPIM) :: J, IER TYPE(MPI_GROUP) :: MPI_GROUP_WORLD,IGROUP TYPE(MPI_COMM) :: COMM_NEW_LOCAL TYPE(MPI_COMM) :: MPL_COMM_INTERNAL LOGICAL :: LLABORT=.TRUE. DO J=1,N IRANK(J)=J-1 ENDDO MPL_COMM_INTERNAL%MPI_VAL = MPL_COMM CALL MPI_COMM_GROUP(MPL_COMM_INTERNAL,MPI_GROUP_WORLD,IER) IF (IER/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_LOCOMM_CREATE: MPI_COMM_GROUP',KERROR=IER,LDABORT=LLABORT) CALL MPI_GROUP_INCL(MPI_GROUP_WORLD,N,IRANK,IGROUP,IER) IF (IER/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_LOCOMM_CREATE: MPI_GROUP_INCL',KERROR=IER,LDABORT=LLABORT) CALL MPI_COMM_CREATE(MPL_COMM_INTERNAL,IGROUP,COMM_NEW_LOCAL,IER) IF (IER/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_LOCOMM_CREATE: MPI_COMM_CREATE',KERROR=IER,LDABORT=LLABORT) KCOMM=COMM_NEW_LOCAL%MPI_VAL RETURN END SUBROUTINE MPL_LOCOMM_CREATE END MODULE MPL_LOCOMM_CREATE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/ec_mpi_finalize.intfb.h0000664000175000017500000000131415157200431025076 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE EC_MPI_FINALIZE(KERROR,LDCALLFINITO,LDMEMINFO,CALLER) USE EC_PARKIND, ONLY : JPIM INTEGER(KIND=JPIM), INTENT(OUT) :: KERROR LOGICAL, INTENT(IN) :: LDCALLFINITO LOGICAL, INTENT(IN) :: LDMEMINFO CHARACTER(LEN=*), INTENT(IN) :: CALLER END SUBROUTINE EC_MPI_FINALIZE END INTERFACE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_abort_mod.F900000664000175000017500000000350215157200431023606 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ABORT_MOD USE EC_PARKIND, ONLY : JPIM USE YOMHOOK, ONLY : LHOOK USE OML_MOD, ONLY : OML_MY_THREAD, OML_MAX_THREADS USE MPL_DATA_MODULE, ONLY : MPL_UNIT, MPL_ERRUNIT USE MPL_MPI, ONLY : MPI_COMM_WORLD PRIVATE PUBLIC MPL_ABORT INTEGER(KIND=JPIM), SAVE :: MAB_CNT = 0 ! Must be used with OMP FLUSH inside the OMP CRITICAL regions CONTAINS SUBROUTINE MPL_ABORT(CDMESSAGE) IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDMESSAGE INTEGER(KIND=JPIM) :: IRETURN_CODE,IERROR,ITID,INUMTH,IPROC,INUM_PROC LOGICAL :: LMPI_INITIALIZED IPROC=1 INUM_PROC=1 CALL MPI_INITIALIZED(LMPI_INITIALIZED,IERROR) IF( LMPI_INITIALIZED ) THEN CALL MPI_COMM_RANK(MPI_COMM_WORLD,IPROC,IERROR) IPROC = IPROC+1 ! 1-based in IFS context CALL MPI_COMM_SIZE(MPI_COMM_WORLD,INUM_PROC,IERROR) ENDIF ITID=OML_MY_THREAD() INUMTH=OML_MAX_THREADS() CALL EC_FLUSH(MPL_UNIT) !------Traceback from only one thread !$OMP CRITICAL (CRIT_MPL_ABORT) !$OMP FLUSH(MAB_CNT) IF (MAB_CNT == 0) THEN IF(PRESENT(CDMESSAGE)) THEN WRITE(MPL_ERRUNIT,'(A,I0,A,I0,A,A)') 'MPL_ABORT [PROC=',IPROC,',THRD=',ITID, '] : ', CDMESSAGE ELSE WRITE(MPL_ERRUNIT,'(A,I0,A,I0,A)') 'MPL_ABORT [PROC=',IPROC,',THRD=',ITID, ']' ENDIF CALL EC_FLUSH(MPL_ERRUNIT) MAB_CNT=1 !$OMP FLUSH(MAB_CNT) CALL TABORT() ! tabort.c : does not hang -- never returns ENDIF !$OMP END CRITICAL (CRIT_MPL_ABORT) END SUBROUTINE MPL_ABORT END MODULE MPL_ABORT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_probe_mod.F900000664000175000017500000001147015157200431023611 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_PROBE_MOD !**** MPL_PROBE - Check for incoming message ! Purpose. ! -------- ! Look for existence of an incoming message. !** Interface. ! ---------- ! CALL MPL_PROBE ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! KSOURCE - rank of process sending the message ! default is MPI_ANY_SOURCE ! KTAG - tag of incoming message ! default is MPI_ANY_TAG ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! LDWAIT - = TRUE : waits for a message to be available ! = FALSE: return immediately and set ! LDFLAG to indicate if a message exists ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_PROBE aborts when an error is detected. ! LDFLAG - must be supplied if LDWAIT=false ! = TRUE if a message exists ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P. Marguinaud : 01-Jan-2011 : Extends original interface with ! KCOUNT,KRECVTAG,KFROM (same meaning as ! in all MPL_* routines) ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_STATUS, MPI_COMM, MPI_ANY_SOURCE, MPI_CHARACTER, MPI_ANY_TAG USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_COMM_OML USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PUBLIC MPL_PROBE PRIVATE !--- Moved into subroutine to make thrreadsafe---- ! INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) ! INTEGER(KIND=JPIM) :: ICOMM,ITAG,ISOURCE,IERROR ! LOGICAL :: LLWAIT,LLABORT=.TRUE. CONTAINS SUBROUTINE MPL_PROBE(KSOURCE,KTAG,KCOMM,LDWAIT,LDFLAG,CDSTRING,KERROR,KCOUNT,KRECVTAG,KFROM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_PROBE => MPI_PROBE8, MPI_IPROBE => MPI_IPROBE8 #endif INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KSOURCE,KTAG,KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR LOGICAL,INTENT(IN), OPTIONAL :: LDWAIT LOGICAL,INTENT(OUT),OPTIONAL :: LDFLAG CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KCOUNT, KRECVTAG, KFROM TYPE(MPI_STATUS) :: IRECV_STATUS INTEGER(KIND=JPIM) :: ITAG,ISOURCE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLWAIT,LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_PROBE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KSOURCE)) THEN ISOURCE=KSOURCE-1 ELSE ISOURCE=MPI_ANY_SOURCE ENDIF IF(PRESENT(KTAG)) THEN ITAG=KTAG ELSE ITAG=MPI_ANY_TAG ENDIF IF(PRESENT(LDWAIT)) THEN LLWAIT=LDWAIT ELSE LLWAIT=.TRUE. ENDIF IF(LLWAIT) THEN CALL MPI_PROBE(ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) IF (IERROR == 0) THEN IF (PRESENT (KCOUNT)) CALL MPI_GET_COUNT (IRECV_STATUS, MPI_CHARACTER, KCOUNT, IERROR) IF (PRESENT (KRECVTAG)) KRECVTAG = IRECV_STATUS%MPI_TAG IF (PRESENT (KFROM)) KFROM = IRECV_STATUS%MPI_SOURCE+1 ENDIF ELSE IF(PRESENT(LDFLAG)) THEN CALL MPI_IPROBE(ISOURCE,ITAG,ICOMM,LDFLAG,IRECV_STATUS,IERROR) IF (IERROR == 0 .AND. LDFLAG) THEN IF (PRESENT (KCOUNT)) CALL MPI_GET_COUNT (IRECV_STATUS, MPI_CHARACTER, KCOUNT, IERROR) IF (PRESENT (KRECVTAG)) KRECVTAG = IRECV_STATUS%MPI_TAG IF (PRESENT (KFROM)) KFROM = IRECV_STATUS%MPI_SOURCE+1 ENDIF ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_PROBE: MUST PROVIDE LDFLAG ',CDSTRING=CDSTRING, & & KERROR=IERROR,LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_PROBE',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_PROBE END MODULE MPL_PROBE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_comm_free_mod.F900000664000175000017500000000213715157200431024436 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_FREE_MOD !**** *MPL_COMM_FREE_MOD* - Release ressources used by a communicator ! Author. ! ------- ! Philippe Marguinaud *METEO FRANCE* ! Original : 11-09-2012 USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_COMM_NULL IMPLICIT NONE PRIVATE PUBLIC :: MPL_COMM_FREE CONTAINS SUBROUTINE MPL_COMM_FREE (KCOMM, KERR, CDSTRING) INTEGER (KIND=JPIM), INTENT (INOUT) :: KCOMM INTEGER (KIND=JPIM), INTENT (OUT) :: KERR CHARACTER (LEN=*), INTENT (IN), OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: LOCALCOMM LOCALCOMM%MPI_VAL=KCOMM CALL MPI_COMM_FREE(LOCALCOMM, KERR) KCOMM=MPI_COMM_NULL%MPI_VAL END SUBROUTINE MPL_COMM_FREE END MODULE MPL_COMM_FREE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_message_mod.F900000664000175000017500000000556615157200431024137 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MESSAGE_MOD !**** MPL_MESSAGE - Prints message ! Purpose. ! -------- ! Creates an ASCII message for printing and optionally aborts !** Interface. ! ---------- ! CALL MPL_MESSAGE ! Input required arguments : ! ------------------------- ! CDMESSAGE- character string for message ! Input optional arguments : ! ------------------------- ! KERROR - Error number ! CDSTRING - Optional additional message ! prepended to CDMESSAGE ! LDABORT - forces ABORT if true ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE MPL_MPI, ONLY : MPI_MAX_ERROR_STRING USE MPL_DATA_MODULE, ONLY : MPL_UNIT, MPL_RANK USE MPL_ABORT_MOD, ONLY : MPL_ABORT USE EC_PARKIND ,ONLY : JPIM PRIVATE PUBLIC MPL_MESSAGE CONTAINS SUBROUTINE MPL_MESSAGE(CDMESSAGE,CDSTRING,KERROR,LDABORT) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ERROR_STRING => MPI_ERROR_STRING8 #endif IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: CDMESSAGE CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KERROR LOGICAL ,INTENT(IN),OPTIONAL :: LDABORT CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: CLMPI_ERROR CHARACTER(LEN=12) :: CLERROR INTEGER(KIND=JPIM) :: IRESULTLEN,IERROR IF(PRESENT(KERROR)) THEN WRITE(CLERROR,'(I0)') KERROR ELSE CLERROR=' ' ENDIF IF(PRESENT(CDSTRING)) THEN WRITE(MPL_UNIT,'(4(1X,A),I0)') CDSTRING,CDMESSAGE,CLERROR, & & ' FROM PROCESSOR ',MPL_RANK ELSE WRITE(MPL_UNIT,'(3(1X,A),I0)') CDMESSAGE,CLERROR, & & ' FROM PROCESSOR ',MPL_RANK ENDIF IF(PRESENT(KERROR)) THEN CALL MPI_ERROR_STRING(KERROR,CLMPI_ERROR,IRESULTLEN,IERROR) WRITE(MPL_UNIT,'(1X,2A,I0)') CLMPI_ERROR(1:IRESULTLEN),' in processor ',MPL_RANK ELSE CLMPI_ERROR=' ' IRESULTLEN=1 ENDIF IF(PRESENT(LDABORT)) THEN IF(LDABORT) THEN WRITE(0,'(1X,2A,I0)') CLMPI_ERROR(1:IRESULTLEN),' in processor ',MPL_RANK CALL MPL_ABORT('ABORT') ENDIF ENDIF RETURN END SUBROUTINE MPL_MESSAGE END MODULE MPL_MESSAGE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_allgatherv_preamble.i900000664000175000017500000000222015157200431025677 0ustar alastairalastairIF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF(ICOMM%MPI_VAL == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV: KREQUEST MISSING',LDABORT=LLABORT) ENDIF IF(PRESENT(KRECVDISPL)) THEN IRECVDISPL_PT => KRECVDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC, KRECV_PT=IRECVDISPL_PT) ELSE ALLOCATE(IRECVDISPL(IPL_NUMPROC)) IRECVDISPL_PT => IRECVDISPL END IF IRECVDISPL_PT(1) = 0 IF (LKRECVCOUNTS) THEN DO IR=2, IPL_NUMPROC IRECVDISPL_PT(IR) = IRECVDISPL_PT(IR-1) + KRECVCOUNTS(IR-1) ENDDO ELSE ! needed only for _int_scalar version where KRECVCOUNTS is optional DO IR=2, IPL_NUMPROC IRECVDISPL_PT(IR) = IRECVDISPL_PT(IR-1) + IRECVCOUNTS(IR-1) ENDDO ENDIF ENDIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/yommplstats.F900000664000175000017500000000172215157200431023366 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE YOMMPLSTATS USE EC_PARKIND ,ONLY : JPRD, JPIM IMPLICIT NONE SAVE PRIVATE :: JPRD, JPIM PUBLIC ! ------------------------------------------------------------------ ! Module for communications statistics. ! Module is internal to the MPLSTATS package - ! routines MPL_SENDSTATS, MPL_RECVSTATS ! LMPLSTATS - TRUE for gathering communications statistics LOGICAL :: LMPLSTATS = .FALSE. REAL(KIND=JPRD), ALLOCATABLE :: MPLSENDBYTES(:), MPLRECVBYTES(:) INTEGER(KIND=JPIM), ALLOCATABLE :: MPLSENDNUM(:), MPLRECVNUM(:) END MODULE YOMMPLSTATS fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_allgather_mod.F900000664000175000017500000000567315157200431024455 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLGATHER_MOD !**** MPL_ALLGATHER Send data to all processes ! Purpose. ! -------- ! Send a message to all processes from a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_ALLGATHER ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PRECVBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_ALLGATHER aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-11-23 ! M.Hamrud : 2014-10-22 : Add nonblocking option ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE PRIVATE INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITAG LOGICAL :: LLBARRIER INTEGER(KIND=JPIM) :: IMAXMSG,JK,IMYPAIR,ICHUNKS,ISTS,ISTR,JMESS,ILENS,IENS,IOUNT,IMP_TYPE INTEGER(KIND=JPIM) :: ILIMIT,IBARRFREQ,IDUM PUBLIC MPL_ALLGATHER CONTAINS SUBROUTINE MPL_ALLGATHER() RETURN END SUBROUTINE MPL_ALLGATHER END MODULE MPL_ALLGATHER_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_allgatherv_mod.F900000664000175000017500000003314115157200431024632 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLGATHERV_MOD !**** MPL_ALLGATHERV Send data to all processes ! Purpose. ! -------- ! Send a message to all processes from a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_ALLGATHERV ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PRECVBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_ALLGATHERV aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-11-23 ! J.Hague: 2004-12-15 : Threadsafe ! M.Hamrud: 2014-10-22 : Add nonblocking option ! F.Vana: 2015-03-05 : Support for single precision ! P.Gillies: 2018-05-30 : Add KSENDCOUNT argument, needed for zero length sends ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM ,JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_REQUEST, MPI_COMM, MPI_REAL4, MPI_REAL8, MPI_INTEGER USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_COMM_OML, MPL_METHOD, MPL_UNIT, MPL_OUTPUT, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. LOGICAL :: LLBARRIER INTERFACE MPL_ALLGATHERV MODULE PROCEDURE MPL_ALLGATHERV_REAL8,MPL_ALLGATHERV_REAL4,& MPL_ALLGATHERV_INT, MPL_ALLGATHERV_INT_SCALAR END INTERFACE PUBLIC MPL_ALLGATHERV CONTAINS SUBROUTINE MPL_ALLGATHERV_REAL4(PSENDBUF,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE REAL(KIND=JPRM) :: PSENDBUF(:) REAL(KIND=JPRM) :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM), TARGET, ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS = .TRUE. ! .TRUE. if KRECVCOUNTS is present (used in _int_scalar version) INTEGER(KIND=JPIM) :: IRECVCOUNTS(1) ! needed for _int_scalar version preamble ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = SIZE(PSENDBUF) ISENDCOUNT = MAX(0,ISENDCOUNT) ! Bug? on IBM ENDIF IRECVCOUNT = SIZE(PRECVBUF) !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !--------- End of Preamble -------------- IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL4,PRECVBUF,& & KRECVCOUNTS,IRECVDISPL_PT,MPI_REAL4,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL4,PRECVBUF,& & KRECVCOUNTS,IRECVDISPL_PT,MPI_REAL4,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL4%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_REAL4%MPI_VAL) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_REAL4 SUBROUTINE MPL_ALLGATHERV_REAL8(PSENDBUF,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE REAL(KIND=JPRD) :: PSENDBUF(:) REAL(KIND=JPRD) :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: ITID,J INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS = .TRUE. ! .TRUE. if KRECVCOUNTS is present (used in _int_scalar version) INTEGER(KIND=JPIM) :: IRECVCOUNTS(1) ! needed for _int_scalar version preamble ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = SIZE(PSENDBUF) ISENDCOUNT = MAX(0,ISENDCOUNT) ! Bug? on IBM ENDIF IRECVCOUNT = SIZE(PRECVBUF) !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !!--------- End of Preamble -------------- IERROR=0 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL8,PRECVBUF,& & KRECVCOUNTS,IRECVDISPL_PT,MPI_REAL8,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL8,PRECVBUF,& & KRECVCOUNTS,IRECVDISPL_PT,MPI_REAL8,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_REAL8%MPI_VAL) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV',CDSTRING=CDSTRING,KERROR=IERROR,& & LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_REAL8 SUBROUTINE MPL_ALLGATHERV_INT(KSENDBUF,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM) :: KSENDBUF(:) INTEGER(KIND=JPIM) :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS = .TRUE. ! .TRUE. if KRECVCOUNTS is present (used in _int_scalar version) INTEGER(KIND=JPIM) :: IRECVCOUNTS(1) ! needed for _int_scalar version preamble ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = SIZE(KSENDBUF) ISENDCOUNT = MAX(0,ISENDCOUNT) ! Bug? on IBM ENDIF IRECVCOUNT = SIZE(KRECVBUF) !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !--------- End of Preamble -------------- IERROR=0 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,& & KRECVCOUNTS,IRECVDISPL_PT,MPI_INTEGER,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,& & KRECVCOUNTS,IRECVDISPL_PT,MPI_INTEGER,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_INTEGER%MPI_VAL) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_INT SUBROUTINE MPL_ALLGATHERV_INT_SCALAR(KSENDBUF,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM) :: KSENDBUF INTEGER(KIND=JPIM) :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: IRECVCOUNTS(MPL_NUMPROC) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS ! .TRUE. if KRECVCOUNTS is present ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = 1 ENDIF IRECVCOUNT = SIZE(KRECVBUF) IF(PRESENT(KRECVCOUNTS)) THEN IF(ANY(KRECVCOUNTS < 0) .OR. ANY(KRECVCOUNTS > 1)) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV_INT_SCALAR: KRECVCOUNTS contains <0 or >1 counts',LDABORT=LLABORT) ENDIF IRECVCOUNTS=KRECVCOUNTS LKRECVCOUNTS = .TRUE. ELSE IRECVCOUNTS(:) = 1 LKRECVCOUNTS = .FALSE. ENDIF !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !--------- End of Preamble -------------- IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,IRECVCOUNTS,& & IRECVDISPL_PT,MPI_INTEGER,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,IRECVCOUNTS,& & IRECVDISPL_PT,MPI_INTEGER,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) CALL MPL_RECVSTATS(SUM(IRECVCOUNTS),MPI_INTEGER%MPI_VAL) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_INT_SCALAR END MODULE MPL_ALLGATHERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_close_mod.F900000664000175000017500000000564215157200431023613 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_CLOSE_MOD ! ! Purpose. close an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_close(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kfptr - handle for file pointer ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_CLOSE) ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND ,ONLY : JPIM USE MPL_MPI, ONLY : MPI_FILE USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO IMPLICIT NONE PRIVATE PUBLIC MPL_CLOSE CONTAINS SUBROUTINE MPL_CLOSE(KFPTR,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_CLOSE => MPI_FILE_CLOSE8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR TYPE(MPI_FILE) :: FH ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF ! ! ----------------------------------------------------------------- ! ! 1. Close the File ! -------------- FH%MPI_VAL=KFPTR CALL MPI_FILE_CLOSE(FH,KERROR) ! ! ----------------------------------------------------------------- #else CALL ABOR1('MPI_CLOSE not built with MPI2') #endif ! RETURN END SUBROUTINE MPL_CLOSE END MODULE MPL_CLOSE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpi4to8_s.F900000664000175000017500000003664315157200431022632 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI4TO8_S #ifdef USE_8_BYTE_WORDS USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF IMPLICIT NONE PRIVATE :: STATUS8 INTEGER(KIND=8), DIMENSION(MPI_STATUS_SIZE) :: STATUS8 INTERFACE MPI_GET_COUNT8 MODULE PROCEDURE MPI_GET_COUNT8_I4, MPI_GET_COUNT8_I4_1 END INTERFACE MPI_GET_COUNT8 INTERFACE MPI_WAITALL8 MODULE PROCEDURE MPI_WAITALL8_I4, MPI_WAITALL8_I4_1 END INTERFACE MPI_WAITALL8 INTERFACE MPI_WAIT8 MODULE PROCEDURE MPI_WAIT8_I4, MPI_WAIT8_I4_1 END INTERFACE MPI_WAIT8 PUBLIC CONTAINS ! --------------------------------------------------------- SUBROUTINE MPI_ABORT8(COMM, ERRORCODE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, ERRORCODE INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COMM8, ERRORCODE8, IERROR8 COMM8 = COMM ERRORCODE8 = ERRORCODE CALL MPI_ABORT(COMM8, ERRORCODE8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_ABORT8 ! --------------------------------------------------------- SUBROUTINE MPI_BARRIER8(COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COMM8, IERROR8 COMM8 = COMM CALL MPI_BARRIER(COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BARRIER8 ! --------------------------------------------------------- SUBROUTINE MPI_BUFFER_DETACH8(BUFFER_ADDR, SZ, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & BUFFER_ADDR INTEGER(KIND=JPIM), INTENT(OUT) :: & SZ, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUFFER_ADDR8 INTEGER(KIND=8) :: & SZ8, IERROR8 ALLOCATE(BUFFER_ADDR8(SIZE(BUFFER_ADDR))) CALL MPI_BUFFER_DETACH(BUFFER_ADDR8, SZ8, IERROR8) BUFFER_ADDR = BUFFER_ADDR8 SZ = SZ8 IERROR = IERROR8 DEALLOCATE(BUFFER_ADDR8) END SUBROUTINE MPI_BUFFER_DETACH8 ! --------------------------------------------------------- SUBROUTINE MPI_BUFFER_ATTACH8(BUFFER_ADDR, SZ, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & BUFFER_ADDR INTEGER(KIND=JPIM), INTENT(IN) :: & SZ INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUFFER_ADDR8 INTEGER(KIND=8) :: & SZ8, IERROR8 ALLOCATE(BUFFER_ADDR8(SIZE(BUFFER_ADDR))) BUFFER_ADDR8 = BUFFER_ADDR SZ8 = SZ CALL MPI_BUFFER_ATTACH(BUFFER_ADDR8, SZ8, IERROR8) IERROR = IERROR8 DEALLOCATE(BUFFER_ADDR8) END SUBROUTINE MPI_BUFFER_ATTACH8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_COORDS8(COMM, RANK, MAXDIMS, COORDS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, RANK, MAXDIMS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: COORDS INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: COORDS8 INTEGER(KIND=8) :: & COMM8, RANK8, MAXDIMS8, IERROR8 ALLOCATE(COORDS8(SIZE(COORDS))) COMM8 = COMM RANK8 = RANK MAXDIMS8 = MAXDIMS CALL MPI_CART_COORDS(COMM8, RANK8, MAXDIMS8, COORDS8, IERROR8) COORDS = COORDS8 IERROR = IERROR8 DEALLOCATE(COORDS8) END SUBROUTINE MPI_CART_COORDS8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_CREATE8(COMM_OLD, NDIMS, DIMS, PERIODS, REORDER, COMM_CART, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM_OLD, NDIMS, DIMS(:) LOGICAL(KIND=JPIM), INTENT(IN) :: & PERIODS(:), REORDER INTEGER(KIND=JPIM), INTENT(OUT) :: & COMM_CART, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DIMS8 INTEGER(KIND=8) :: & COMM_OLD8, NDIMS8, COMM_CART8, IERROR8 LOGICAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & PERIODS8 LOGICAL(KIND=8) :: & REORDER8 ALLOCATE(DIMS8(SIZE(DIMS))) ALLOCATE(PERIODS8(SIZE(PERIODS))) COMM_OLD8 = COMM_OLD NDIMS8 = NDIMS DIMS8 = DIMS PERIODS8 = PERIODS REORDER8 = REORDER CALL MPI_CART_CREATE(COMM_OLD8, NDIMS8, DIMS8, PERIODS8, REORDER8, COMM_CART8, IERROR8) COMM_CART = COMM_CART8 IERROR = IERROR8 DEALLOCATE(DIMS8) DEALLOCATE(PERIODS8) END SUBROUTINE MPI_CART_CREATE8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_RANK8(COMM, COORDS, RANK, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(IN), DIMENSION(:) :: COORDS INTEGER(KIND=JPIM), INTENT(OUT) :: & RANK, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: COORDS8 INTEGER(KIND=8) :: & COMM8, RANK8, IERROR8 ALLOCATE(COORDS8(SIZE(COORDS))) COMM8 = COMM COORDS8 = COORDS CALL MPI_CART_RANK(COMM8, COORDS8, RANK8, IERROR8) RANK = RANK8 IERROR = IERROR8 DEALLOCATE(COORDS8) END SUBROUTINE MPI_CART_RANK8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_SUB8(COMM, REMAIN_DIMS, NEWCOMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM LOGICAL(KIND=JPIM), INTENT(IN), DIMENSION(:) :: & REMAIN_DIMS INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWCOMM, IERROR INTEGER(KIND=8) :: & COMM8, NEWCOMM8, IERROR8 LOGICAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & REMAIN_DIMS8 ALLOCATE(REMAIN_DIMS8(SIZE(REMAIN_DIMS))) COMM8 = COMM REMAIN_DIMS8 = REMAIN_DIMS CALL MPI_CART_SUB(COMM8, REMAIN_DIMS8, NEWCOMM8, IERROR8) NEWCOMM = NEWCOMM8 IERROR = IERROR8 DEALLOCATE(REMAIN_DIMS8) END SUBROUTINE MPI_CART_SUB8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_CREATE8(COMM, GROUP, NEWCOMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, GROUP INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWCOMM, IERROR INTEGER(KIND=8) :: & COMM8, GROUP8, NEWCOMM8, IERROR8 COMM8 = COMM GROUP8 = GROUP CALL MPI_COMM_CREATE(COMM8, GROUP8, NEWCOMM8, IERROR8) NEWCOMM = NEWCOMM8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_CREATE8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_GROUP8(COMM, GROUP, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & GROUP, IERROR INTEGER(KIND=8) :: & COMM8, GROUP8, IERROR8 COMM8 = COMM CALL MPI_COMM_GROUP(COMM8, GROUP8, IERROR8) GROUP = GROUP8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_GROUP8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_RANK8(COMM, RANK, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RANK, IERROR INTEGER(KIND=8) :: & COMM8, RANK8, IERROR8 COMM8 = COMM CALL MPI_COMM_RANK(COMM8, RANK8, IERROR8) RANK = RANK8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_RANK8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_SIZE8(COMM, SIZE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & SIZE, IERROR INTEGER(KIND=8) :: & COMM8, SIZE8, IERROR8 COMM8 = COMM CALL MPI_COMM_SIZE(COMM8, SIZE8, IERROR8) SIZE = SIZE8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_SIZE8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_SPLIT8(COMM, COLOR, KEY, NEWCOMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, COLOR, KEY INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWCOMM, IERROR INTEGER(KIND=8) :: & COMM8, COLOR8, KEY8, NEWCOMM8, IERROR8 COMM8 = COMM COLOR8 = COLOR KEY8 = KEY CALL MPI_COMM_SPLIT(COMM8, COLOR8, KEY8, NEWCOMM8, IERROR8) NEWCOMM = NEWCOMM8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_SPLIT8 ! --------------------------------------------------------- SUBROUTINE MPI_ERROR_STRING8(ERRORCODE, STRING, RESULTLEN, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & ERRORCODE CHARACTER(LEN=*), INTENT(OUT) :: & STRING INTEGER(KIND=JPIM), INTENT(OUT) :: & RESULTLEN, IERROR INTEGER(KIND=8) :: & ERRORCODE8, RESULTLEN8, IERROR8 ERRORCODE8 = ERRORCODE CALL MPI_ERROR_STRING(ERRORCODE8, STRING, RESULTLEN8, IERROR8) RESULTLEN = RESULTLEN8 IERROR = IERROR8 END SUBROUTINE MPI_ERROR_STRING8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_CLOSE8(FH, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, IERROR8 FH8 = FH CALL MPI_FILE_CLOSE(FH8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FILE_CLOSE8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_OPEN8(COMM, FILENAME, AMODE, INFO, FH, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, AMODE, INFO CHARACTER(LEN=*), INTENT(IN) :: & FILENAME INTEGER(KIND=JPIM), INTENT(OUT) :: & FH, IERROR INTEGER(KIND=8) :: & COMM8, AMODE8, INFO8, FH8, IERROR8 COMM8 = COMM AMODE8 = AMODE INFO8 = INFO CALL MPI_FILE_OPEN(COMM8, FILENAME, AMODE8, INFO8, FH8, IERROR8) FH = FH8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_OPEN8 ! --------------------------------------------------------- SUBROUTINE MPI_FINALIZE8(IERROR) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & IERROR8 CALL MPI_FINALIZE(IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FINALIZE8 ! --------------------------------------------------------- SUBROUTINE MPI_GET_COUNT8_I4(STATUS, DATATYPE, COUNT, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & STATUS(:), DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & COUNT, IERROR INTEGER(KIND=8) :: & DATATYPE8, COUNT8, IERROR8 STATUS8 = STATUS DATATYPE8 = DATATYPE CALL MPI_GET_COUNT(STATUS8, DATATYPE8, COUNT8, IERROR8) COUNT = COUNT8 IERROR = IERROR8 END SUBROUTINE MPI_GET_COUNT8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_GET_COUNT8_I4_1(STATUS, DATATYPE, COUNT, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & STATUS, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & COUNT, IERROR INTEGER(KIND=8) :: & DATATYPE8, COUNT8, IERROR8, STATUS8 STATUS8 = STATUS DATATYPE8 = DATATYPE CALL MPI_GET_COUNT(STATUS8, DATATYPE8, COUNT8, IERROR8) COUNT = COUNT8 IERROR = IERROR8 END SUBROUTINE MPI_GET_COUNT8_I4_1 ! --------------------------------------------------------- SUBROUTINE MPI_GROUP_INCL8(GROUP1, N, RANKS, NEWGROUP, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & GROUP1, N, RANKS(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWGROUP, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RANKS8 INTEGER(KIND=8) :: & GROUP18, N8, NEWGROUP8, IERROR8 ALLOCATE(RANKS8(SIZE(RANKS))) GROUP18 = GROUP1 N8 = N RANKS8 = RANKS CALL MPI_GROUP_INCL(GROUP18, N8, RANKS8, NEWGROUP8, IERROR8) NEWGROUP = NEWGROUP8 IERROR = IERROR8 DEALLOCATE(RANKS8) END SUBROUTINE MPI_GROUP_INCL8 ! --------------------------------------------------------- SUBROUTINE MPI_INIT8(IERROR) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & IERROR8 CALL MPI_INIT(IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_INIT8 ! --------------------------------------------------------- SUBROUTINE MPI_INITIALIZED8(FLAG, IERROR) INTEGER(KIND=JPIM), INTENT(OUT) :: & FLAG INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FLAG8 INTEGER(KIND=8) :: & IERROR8 CALL MPI_INITIALIZED(FLAG8, IERROR8) FLAG = FLAG8 IERROR = IERROR8 END SUBROUTINE MPI_INITIALIZED8 ! --------------------------------------------------------- SUBROUTINE MPI_IPROBE8(SOURCE, TAG, COMM, FLAG, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & FLAG INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & SOURCE8, TAG8, COMM8, IERROR8 INTEGER(KIND=8) :: & FLAG8 SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IPROBE(SOURCE8, TAG8, COMM8, FLAG8, STATUS8, IERROR8) FLAG = FLAG8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_IPROBE8 ! --------------------------------------------------------- SUBROUTINE MPI_PROBE8(SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & SOURCE8, TAG8, COMM8, IERROR8 SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_PROBE(SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_PROBE8 ! --------------------------------------------------------- SUBROUTINE MPI_WAIT8_I4(REQUEST, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(INOUT) :: & REQUEST INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & REQUEST8, IERROR8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: STATUS8 ALLOCATE(STATUS8(SIZE(STATUS))) REQUEST8 = REQUEST CALL MPI_WAIT(REQUEST8, STATUS8, IERROR8) REQUEST = REQUEST8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(STATUS8) END SUBROUTINE MPI_WAIT8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_WAIT8_I4_1(REQUEST, STATUS, IERROR) INTEGER(KIND=JPIM) :: & REQUEST INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS, IERROR INTEGER(KIND=8) :: & REQUEST8, IERROR8, STATUS8 REQUEST8 = REQUEST CALL MPI_WAIT(REQUEST8, STATUS8, IERROR8) REQUEST = REQUEST8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_WAIT8_I4_1 ! --------------------------------------------------------- SUBROUTINE MPI_WAITALL8_I4(COUNT, ARRAY_OF_REQUESTS, ARRAY_OF_STATUSES, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT INTEGER(KIND=JPIM), DIMENSION(:), INTENT(INOUT) :: & ARRAY_OF_REQUESTS INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & ARRAY_OF_STATUSES INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & ARRAY_OF_REQUESTS8 INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & ARRAY_OF_STATUSES8 INTEGER(KIND=8) :: & COUNT8, IERROR8 INTEGER :: N COUNT8 = COUNT ALLOCATE(ARRAY_OF_REQUESTS8(SIZE(ARRAY_OF_REQUESTS))) N = SIZE(ARRAY_OF_STATUSES) / MPI_STATUS_SIZE ALLOCATE(ARRAY_OF_STATUSES8(MPI_STATUS_SIZE,N)) ARRAY_OF_REQUESTS8 = ARRAY_OF_REQUESTS CALL MPI_WAITALL(COUNT8, ARRAY_OF_REQUESTS8, ARRAY_OF_STATUSES8, IERROR8) ARRAY_OF_REQUESTS = ARRAY_OF_REQUESTS8 ARRAY_OF_STATUSES = ARRAY_OF_STATUSES8 DEALLOCATE(ARRAY_OF_REQUESTS8) DEALLOCATE(ARRAY_OF_STATUSES8) IERROR = IERROR8 END SUBROUTINE MPI_WAITALL8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_WAITALL8_I4_1(COUNT, ARRAY_OF_REQUESTS, ARRAY_OF_STATUSES, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT INTEGER(KIND=JPIM) :: & ARRAY_OF_REQUESTS INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & ARRAY_OF_STATUSES INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & ARRAY_OF_REQUESTS8 INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & ARRAY_OF_STATUSES8 INTEGER(KIND=8) :: & COUNT8, IERROR8 INTEGER :: N COUNT8 = COUNT N = SIZE(ARRAY_OF_STATUSES) / MPI_STATUS_SIZE ALLOCATE(ARRAY_OF_STATUSES8(MPI_STATUS_SIZE,N)) ARRAY_OF_REQUESTS8 = ARRAY_OF_REQUESTS CALL MPI_WAITALL(COUNT8, ARRAY_OF_REQUESTS8, ARRAY_OF_STATUSES8, IERROR8) ARRAY_OF_REQUESTS = ARRAY_OF_REQUESTS8 ARRAY_OF_STATUSES = ARRAY_OF_STATUSES8 DEALLOCATE(ARRAY_OF_STATUSES8) IERROR = IERROR8 END SUBROUTINE MPI_WAITALL8_I4_1 #endif END MODULE MPI4TO8_S fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_comm_create_mod.F900000664000175000017500000000330215157200431024753 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_CREATE_MOD !**** MPL_COMM_CREATE Create a new communicator ! Purpose. ! -------- ! Create a new communicator and set as default !** Interface. ! ---------- ! CALL MPL_COMM_CREATE ! Input required arguments : ! ------------------------- ! Input optional arguments : ! ------------------------- ! Output required arguments : ! ------------------------- ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_COMM_CREATE aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_DATA_MODULE, ONLY : MPL_COMM, MPL_COMM_OML IMPLICIT NONE PRIVATE PUBLIC MPL_COMM_CREATE CONTAINS SUBROUTINE MPL_COMM_CREATE(KERROR) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() ! this line to be replaced MPL_COMM_OML(ITID)=MPL_COMM KERROR=0 RETURN END SUBROUTINE MPL_COMM_CREATE END MODULE MPL_COMM_CREATE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_gatherv_array_tmpl.i900000664000175000017500000000515515157200431025603 0ustar alastairalastairIF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT=KSENDCOUNT ELSE ISENDCOUNT = SIZE(PSENDBUF) ENDIF #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM%MPI_VAL,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. LLPRESENT_RECVBUF) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = SIZE(PRECVBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PRECVBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif ! need to ckeck if krecvcount is present, it is needed on root rank IF( .NOT. PRESENT(KRECVCOUNTS)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:KRECVCOUNTS MISSING ON ROOT RANK',CDSTRING=CDSTRING,LDABORT=LLABORT) CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & KRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF,ISENDCOUNT,IDATA_TYPE,PRECVBUF(1),KRECVCOUNTS, & & IRECVDISPL_PT,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF,ISENDCOUNT,IDATA_TYPE,PRECVBUF(1),KRECVCOUNTS, & & IRECVDISPL_PT,IDATA_TYPE,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,IDATA_TYPE%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),IDATA_TYPE%MPI_VAL) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF,ISENDCOUNT,IDATA_TYPE,ZDUM_JPRM,ONES, & & ONES,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF,ISENDCOUNT,IDATA_TYPE,ZDUM_JPRM,ONES, & & ONES,IDATA_TYPE,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,IDATA_TYPE%MPI_VAL) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_GATHERV',CDSTRING=CDSTRING,& & KERROR=IERROR,LDABORT=LLABORT) ENDIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_stats_mod.F900000664000175000017500000001721715157200431023645 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_STATS_MOD USE EC_PARKIND , ONLY : JPIM, JPRD USE MPL_MPI, ONLY : MPI_DATATYPE, MPI_TYPE_SIZE USE YOMMPLSTATS, ONLY : LMPLSTATS, MPLSENDBYTES, MPLRECVBYTES, MPLSENDNUM, MPLRECVNUM USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE PRIVATE PUBLIC :: MPL_STATSINIT, MPL_STATSON, MPL_STATSREAD, MPL_SENDSTATS, MPL_RECVSTATS CONTAINS SUBROUTINE MPL_STATSINIT !**** MPL_STATSINIT - Initialise collection of mpl statistics ! Purpose. ! -------- ! Initialises the mpl_stats package !** Interface. ! ---------- ! CALL MPL_STATSINIT ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) :: ITHR,OMP_GET_MAX_THREADS LMPLSTATS=.TRUE. ITHR = 1 !$ ITHR = OMP_GET_MAX_THREADS() ITHR = ITHR-1 ALLOCATE(MPLSENDBYTES(0:ITHR)) ALLOCATE(MPLRECVBYTES(0:ITHR)) ALLOCATE(MPLSENDNUM(0:ITHR)) ALLOCATE(MPLRECVNUM(0:ITHR)) MPLSENDBYTES(:) = 0 MPLRECVBYTES(:) = 0 MPLSENDNUM(:) = 0 MPLRECVNUM(:) = 0 RETURN END SUBROUTINE MPL_STATSINIT SUBROUTINE MPL_STATSON(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) !**** MPL_STATSON - Reset mpl statistics counters ! Purpose. ! -------- ! Returns the mpl statistics counter values ! and sets them back to zero ! non zero returned values correspond to messages that have ! been sent/received outside of a GSTATS MPL region !** Interface. ! ---------- ! CALL MPL_STATSON(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! SENDNUM - number of unknown messages sent ! SENDBYTES - number of unknown bytes sent ! RECVNUM - number of unknown messages received ! RECVBYTES - number of unknown bytes received ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE REAL(KIND=JPRD), INTENT(OUT) :: SENDBYTES,RECVBYTES INTEGER(KIND=JPIM), INTENT(OUT) :: SENDNUM,RECVNUM SENDBYTES = SUM(MPLSENDBYTES(:)) RECVBYTES = SUM(MPLRECVBYTES(:)) SENDNUM = SUM(MPLSENDNUM(:)) RECVNUM = SUM(MPLRECVNUM(:)) MPLSENDBYTES(:)=0.0_JPRD MPLRECVBYTES(:)=0.0_JPRD MPLSENDNUM(:)=0 MPLRECVNUM(:)=0 RETURN END SUBROUTINE MPL_STATSON SUBROUTINE MPL_STATSREAD(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) !**** MPL_STATSREAD - read mpl statistics counters ! Purpose. ! -------- ! returns the mpl statistics counter values ! before setting them back to zero !** Interface. ! ---------- ! CALL MPL_STATSREAD(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! SENDNUM - number of messages sent ! SENDBYTES - number of bytes sent ! RECVNUM - number of messages received ! RECVBYTES - number of bytes received ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE REAL(KIND=JPRD), INTENT(OUT) :: SENDBYTES,RECVBYTES INTEGER(KIND=JPIM), INTENT(OUT) :: SENDNUM,RECVNUM SENDNUM=SUM(MPLSENDNUM(:)) RECVNUM=SUM(MPLRECVNUM(:)) SENDBYTES=SUM(MPLSENDBYTES(:)) RECVBYTES=SUM(MPLRECVBYTES (:)) MPLSENDNUM(:)=0 MPLRECVNUM(:)=0 MPLSENDBYTES(:)=0.0_JPRD MPLRECVBYTES(:)=0.0_JPRD RETURN END SUBROUTINE MPL_STATSREAD SUBROUTINE MPL_SENDSTATS(ICOUNT,ITYPE) !**** MPL_SENDSTATS - collect mpl send statistics ! Purpose. ! -------- ! counts the number of messages and volume sent !** Interface. ! ---------- ! CALL MPL_SENDSTATS(ICOUNT,ITYPE) ! Input required arguments : ! ------------------------- ! ICOUNT - The number of elements sent ! ITYPE - The type of an element ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: ICOUNT INTEGER(KIND=JPIM),INTENT(IN) :: ITYPE TYPE(MPI_DATATYPE) :: ITYPE_LOCAL INTEGER(KIND=JPIM) :: ISIZE,IERR,ITH,OMP_GET_THREAD_NUM ITYPE_LOCAL%MPI_VAL=ITYPE ITH = 0 !$ ITH = OMP_GET_THREAD_NUM() MPLSENDNUM(ITH) = MPLSENDNUM(ITH) + 1 CALL MPI_TYPE_SIZE(ITYPE_LOCAL,ISIZE,IERR) MPLSENDBYTES(ITH)=MPLSENDBYTES(ITH) + FLOAT(ISIZE * ICOUNT) RETURN END SUBROUTINE MPL_SENDSTATS SUBROUTINE MPL_RECVSTATS(ICOUNT,ITYPE) !**** MPL_RECVSTATS - collect mpl recv statistics ! Purpose. ! -------- ! counts the number of messages and volume received !** Interface. ! ---------- ! CALL MPL_RECVSTATS(ICOUNT,ITYPE) ! Input required arguments : ! ------------------------- ! ICOUNT - The number of elements received ! ITYPE - The type of an element ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: ICOUNT INTEGER(KIND=JPIM),INTENT(IN) :: ITYPE TYPE(MPI_DATATYPE) :: ITYPE_LOCAL INTEGER(KIND=JPIM) :: ISIZE,IERR,ITH,OMP_GET_THREAD_NUM ITYPE_LOCAL%MPI_VAL=ITYPE ITH = 0 !$ ITH = OMP_GET_THREAD_NUM() MPLRECVNUM(ITH) = MPLRECVNUM(ITH) + 1 CALL MPI_TYPE_SIZE(ITYPE_LOCAL,ISIZE,IERR) MPLRECVBYTES(ITH)=MPLRECVBYTES(ITH) + FLOAT(ISIZE * ICOUNT) RETURN END SUBROUTINE MPL_RECVSTATS END MODULE MPL_STATS_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpi_f08_dummy_mod.F900000664000175000017500000000323715157200431024311 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! (C) Copyright 2024- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI_F08 INTEGER :: MPI_UNDEFINED, MPI_MAX_ERROR_STRING, MPI_ANY_TAG, MPI_ANY_SOURCE, & & MPI_IDENT, MPI_CONGRUENT, MPI_SIMILAR, MPI_THREAD_SINGLE, MPI_THREAD_MULTIPLE, & & MPI_MODE_RDONLY, MPI_MODE_WRONLY, MPI_MODE_CREATE !! dummy type definitions !!======================== TYPE MPI_COMM INTEGER :: MPI_VAL END TYPE TYPE MPI_DATATYPE INTEGER :: MPI_VAL END TYPE TYPE MPI_STATUS INTEGER :: MPI_TAG, MPI_SOURCE END TYPE TYPE MPI_REQUEST INTEGER :: MPI_VAL END TYPE TYPE MPI_FILE INTEGER :: MPI_VAL END TYPE TYPE MPI_OP END TYPE TYPE MPI_GROUP END TYPE TYPE MPI_INFO END TYPE !! dummy instances !!================= TYPE(MPI_DATATYPE) :: MPI_BYTE, MPI_LOGICAL, MPI_CHARACTER, MPI_INTEGER, MPI_INTEGER4, MPI_INTEGER8, MPI_REAL4, MPI_REAL8 TYPE(MPI_OP) :: MPI_MAX, MPI_MIN, MPI_SUM, MPI_BXOR TYPE(MPI_REQUEST) :: MPI_REQUEST_NULL TYPE(MPI_COMM) :: MPI_COMM_WORLD, MPI_COMM_NULL TYPE(MPI_INFO) :: MPI_INFO_NULL !! symbols defined in mpi_serial library, and picked up via a 'USE MPL_MPI' important statement !!============================================================================================== EXTERNAL :: MPI_COMM_SIZE, MPI_TYPE_SIZE, MPI_ALLREDUCE, MPI_COMM_CREATE, MPI_COMM_GROUP END MODULE MPI_F08 fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_waitany_mod.F900000664000175000017500000000643115157200431024157 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_WAITANY_MOD !**** MPL_WAITANY Waits for completion of any request ! Purpose. ! -------- ! Returns control when any operation identified by the request ! is completed. ! Normally used in conjunction with non-blocking buffering type !** Interface. ! ---------- ! CALL MPL_WAITANY ! Input required arguments : ! ------------------------- ! KREQUEST - array or scalar containing ! Communication request(s) ! as provided by MPL_RECV or MPL_SEND ! Input optional arguments : ! ------------------------- ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! KINDEX - index of received request ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_WAITANY aborts when an error is detected. ! Author. ! ------- ! R. El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original: 02-Sep-2014 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM ,JPRM, JPIB USE MPL_MPI, ONLY : MPI_REQUEST, MPI_STATUS, MPI_UNDEFINED USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_WAITANY CONTAINS SUBROUTINE MPL_WAITANY(KREQUEST,KINDEX,CDSTRING,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITANY => MPI_WAITANY8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KREQUEST(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KINDEX CHARACTER(LEN=*) ,INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR TYPE(MPI_REQUEST) :: IREQUEST_LOCAL(SIZE(KREQUEST)) INTEGER(KIND=JPIM) :: IWAITERR,IREQLEN,J TYPE(MPI_STATUS) :: IWAIT_STATUS LOGICAL :: LLABORT LLABORT=.TRUE. IWAITERR=0 IREQUEST_LOCAL(:)%MPI_VAL=KREQUEST IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAITANY: MPL NOT INITIALISED ',LDABORT=LLABORT) KINDEX = MPI_UNDEFINED IREQLEN=SIZE(KREQUEST) #ifndef MPI1 CALL MPI_WAITANY(IREQLEN,IREQUEST_LOCAL,KINDEX,IWAIT_STATUS,IWAITERR) #else !CALL ABOR1('MPI_WAITANY not built with MPI2') IWAITERR = MPI_ERR_UNKNOWN ! Initialized in case all requests already NULL (= logic err in code) DO J=1,IREQLEN IF (IREQUEST_LOCAL(J) /= MPI_REQUEST_NULL) THEN CALL MPI_WAIT(IREQUEST_LOCAL(J),IWAIT_STATUS,IWAITERR) KINDEX = J EXIT ENDIF ENDDO #endif KREQUEST(:)=IREQUEST_LOCAL(:)%MPI_VAL IF(PRESENT(KERROR))THEN KERROR=IWAITERR ELSE IF(IWAITERR /= 0) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_WAITANY_WAITING',CDSTRING=CDSTRING,KERROR=IWAITERR,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_WAITANY END MODULE MPL_WAITANY_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_recv_mod.F900000664000175000017500000010364615157200431023450 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_RECV_MOD !**** MPL_RECV Receive a message ! Purpose. ! -------- ! Receive a message from a named source into a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or REAL or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_RECV ! Input required arguments : ! ------------------------- ! PBUF - buffer to receive the message ! (can be type REAL*4, REAL*8 or INTEGER) ! Input optional arguments : ! ------------------------- ! KTAG - message tag ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KSOURCE - rank of process sending the message ! default is MPI_ANY_SOURCE ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KFROM - rank of process sending the message ! KRECVTAG - tag of received message ! KOUNT - number of items in received message ! KERROR - return error code. If not supplied, ! MPL_RECV aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIB, JPIM, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_STATUS, MPI_DATATYPE, MPI_COMM, MPI_REQUEST, MPI_ANY_SOURCE, MPI_ANY_TAG, & & MPI_REAL4, MPI_REAL8, MPI_INTEGER, MPI_INTEGER8, MPI_BYTE USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_METHOD, MPL_COMM_OML, MPL_ERRUNIT, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_NPROC_MOD, ONLY : MPL_NPROC IMPLICIT NONE PRIVATE INTERFACE MPL_RECV MODULE PROCEDURE MPL_RECV_REAL4, MPL_RECV_REAL8, & & MPL_RECV_INT, MPL_RECV_REAL42, MPL_RECV_REAL43, & & MPL_RECV_REAL82, MPL_RECV_REAL83, MPL_RECV_INT_SCALAR, & & MPL_RECV_INT2, MPL_RECV_REAL4_SCALAR, & & MPL_RECV_REAL8_SCALAR, MPL_RECV_CHAR_SCALAR, & & MPL_RECV_INT8, MPL_RECV_CHAR END INTERFACE PUBLIC MPL_RECV CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_PREAMB(KMP_TYPER,KCOMMR,KSOURCER,KTAGR,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) INTEGER(KIND=JPIM),INTENT(OUT) :: KMP_TYPER,KCOMMR,KSOURCER,KTAGR INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KMP_TYPE,KCOMM,KSOURCE,KTAG INTEGER(KIND=JPIM),OPTIONAL :: KREQUEST LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_RECV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN KMP_TYPER=KMP_TYPE ELSE KMP_TYPER=MPL_METHOD ENDIF IF(KMP_TYPER == JP_NON_BLOCKING_STANDARD) THEN IF( .NOT. PRESENT(KREQUEST)) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:KREQUEST MISSING ',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KCOMM)) THEN KCOMMR=KCOMM ELSE KCOMMR=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KSOURCE)) THEN IF(KSOURCE < 1 .OR. KSOURCE >MPL_NPROC(KCOMMR)) THEN WRITE(MPL_ERRUNIT,*)'MPL_RECV: ERROR KSOURCE=',KSOURCE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL KSOURCE ',LDABORT=LLABORT) ENDIF KSOURCER=KSOURCE-1 ELSE KSOURCER=MPI_ANY_SOURCE ENDIF IF(PRESENT(KTAG)) THEN KTAGR=KTAG ELSE KTAGR=MPI_ANY_TAG ENDIF END SUBROUTINE MPL_RECV_PREAMB ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_TAIL(KRECV_STATUS,KTYPE,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_GET_COUNT => MPI_GET_COUNT8 #endif TYPE(MPI_STATUS), INTENT(IN) :: KRECV_STATUS TYPE(MPI_DATATYPE),INTENT(IN) :: KTYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: IFROM,IRECVTAG,IRECVCOUNT LOGICAL :: LLABORT=.TRUE. IFROM=KRECV_STATUS%MPI_SOURCE+1 IF(PRESENT(KFROM)) THEN KFROM=IFROM ENDIF CALL MPI_GET_COUNT(KRECV_STATUS,KTYPE,IRECVCOUNT,IERROR) IF(PRESENT(KOUNT)) THEN KOUNT=IRECVCOUNT ENDIF IF(LMPLSTATS) CALL MPL_RECVSTATS(IRECVCOUNT,KTYPE%MPI_VAL) IRECVTAG=KRECV_STATUS%MPI_TAG IF(PRESENT(KRECVTAG)) THEN KRECVTAG=IRECVTAG ENDIF !IF(MPL_OUTPUT > 1 )THEN ! WRITE(MPL_UNIT,'(A,5I8)') ' MPL_RECV ',IRECVCOUNT,IMP_TYPE,IFROM,IRECVTAG,ICOMM !ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_RECV_TAIL ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL4(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM,1,MPI_REAL4,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL4,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL4%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL4 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL8(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif ! real_b,intent(in) :: PBUF(:) REAL(KIND=JPRD) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM,1,MPI_REAL8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL8,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL8%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL8 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_INT(KBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,KOUNT,& &KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIM) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID,IDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(IDUM,1,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(IDUM,1,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(IDUM,1,MPI_INTEGER,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KBUF,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KBUF,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KBUF,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_INTEGER,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_INTEGER%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_INT SUBROUTINE MPL_RECV_INT8(KBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,KOUNT,& &KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIB) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIB) :: IDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0 ) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(IDUM,1,MPI_INTEGER8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(IDUM,1,MPI_INTEGER8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(IDUM,1,MPI_INTEGER8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KBUF,IBUFFSIZE,MPI_INTEGER8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KBUF,IBUFFSIZE,MPI_INTEGER8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KBUF,IBUFFSIZE,MPI_INTEGER8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_INTEGER8,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_INTEGER8%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_INT8 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_INT2(KBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIM) :: KBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID, IDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0 ) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(IDUM,1,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(IDUM,1,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(IDUM,1,MPI_INTEGER,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KBUF,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KBUF,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KBUF,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_INTEGER,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_INTEGER%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_INT2 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_INT_SCALAR(KINT,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIM) :: KINT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KINT,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KINT,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KINT,IBUFFSIZE,MPI_INTEGER,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_INTEGER,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_INTEGER%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_INT_SCALAR ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL4_SCALAR(PREAL4,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PREAL4 INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PREAL4,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PREAL4,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PREAL4,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL4,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL4%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL4_SCALAR ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL8_SCALAR(PREAL8,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRD) :: PREAL8 INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PREAL8,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PREAL8,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PREAL8,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL8,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL8%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL8_SCALAR ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL42(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM,1,MPI_REAL4,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL4,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL4%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL42 SUBROUTINE MPL_RECV_REAL43(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,MPI_REAL4,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL4,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL4%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL43 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL82(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRD) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM,1,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM,1,MPI_REAL8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL8,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL8%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL82 SUBROUTINE MPL_RECV_REAL83(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRD) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,MPI_REAL8,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_REAL8,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_REAL8%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_REAL83 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_CHAR_SCALAR(CDCHAR,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif CHARACTER(LEN=*) :: CDCHAR INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = LEN(CDCHAR) IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,MPI_BYTE,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,MPI_BYTE,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(CDCHAR,IBUFFSIZE,MPI_BYTE,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_BYTE,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_BYTE%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_CHAR_SCALAR SUBROUTINE MPL_RECV_CHAR(CDCHAR,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif CHARACTER(LEN=*) :: CDCHAR(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG TYPE(MPI_STATUS) :: IRECV_STATUS LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM%MPI_VAL,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = LEN(CDCHAR) * SIZE(CDCHAR) IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,MPI_BYTE,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,MPI_BYTE,ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(CDCHAR,IBUFFSIZE,MPI_BYTE,ISOURCE,ITAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,MPI_BYTE,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,MPI_BYTE%MPI_VAL) ENDIF END SUBROUTINE MPL_RECV_CHAR ! ------------------------------------------------------------------ END MODULE MPL_RECV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_displs_container_mod.F900000664000175000017500000002321615157200431026043 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. MODULE MPL_DISPLS_CONTAINER_MOD !**** MPL_DISPLS_CONTAINER_MOD - Container for the displacements arrays ! Purpose. ! -------- ! This module provides a container for the displacements arrays ! used in the non-blocking collectives when they are not provided by the caller routine. ! !** Interface. ! ---------- ! CALL YDDISPLS%APPEND(REQ, NPROC, SEND_PT, RECV_PT, NO_NEW_NODE) ! Input optional arguments : ! ------------------------- ! REQ - Request ID ! NPROC - Number of processes in communicator ! NO_NEW_NODE - If present, the new node is not created, the current node is updated ! Output optional arguments : ! ------------------------- ! RECV_PT - Pointer to the recv displacements array ! SEND_PT - Pointer to the send displacements array !** Interface. ! ---------- ! CALL YDDISPLS%REMOVE_REQ(REQ) ! Input required arguments : ! ------------------------- ! REQ - Request ID whose associate node to be removed !** Interface. ! ---------- ! CALL YDDISPLS%TEST_REQ() ! Author. ! ------- ! L. Anton ! Modifications. ! -------------- ! Original: 2025-04-01 USE EC_PARKIND, ONLY : JPIM USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_DATA_MODULE, ONLY : MPL_ERRUNIT, MPL_RANK IMPLICIT NONE PRIVATE TYPE, PRIVATE :: DISPLACEMENTS INTEGER(KIND=JPIM) :: REQ INTEGER(KIND=JPIM) :: NPROC = 0 INTEGER(KIND=JPIM), ALLOCATABLE :: SEND(:) INTEGER(KIND=JPIM), ALLOCATABLE :: RECV(:) TYPE(DISPLACEMENTS), POINTER :: PREV CONTAINS PROCEDURE :: INITIALIZE PROCEDURE :: GET_SEND PROCEDURE :: GET_RECV PROCEDURE :: GET_REQ PROCEDURE :: GET_NPROC END TYPE DISPLACEMENTS TYPE, PUBLIC :: LIST_MANAGER TYPE(DISPLACEMENTS), POINTER :: HEAD => NULL() INTEGER :: LIST_SIZE = 0 CONTAINS PROCEDURE :: APPEND PROCEDURE :: REMOVE_FIRST PROCEDURE :: REMOVE_REQ1 PROCEDURE :: REMOVE_REQS PROCEDURE :: CLEAR_LIST PROCEDURE :: PRINT_LIST GENERIC :: REMOVE_REQ => REMOVE_REQ1, REMOVE_REQS END TYPE LIST_MANAGER LOGICAL :: LLABORT = .TRUE. INTEGER, PARAMETER :: ITEST_SIZE = 20! ! Drop a warning if the linked list size exceeds this value ! It is not expected to have a large number of active displacements in the list TYPE(LIST_MANAGER),PUBLIC,TARGET :: YDDISPLS_LIST ! the only instance of the list manager CONTAINS SUBROUTINE INITIALIZE(THIS, KREQ, KNPROC, KSEND_PT, KRECV_PT) CLASS(DISPLACEMENTS), TARGET, INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KREQ, KNPROC INTEGER(KIND=JPIM), POINTER, INTENT(OUT), OPTIONAL :: KSEND_PT(:), KRECV_PT(:) IF ( PRESENT(KREQ)) THEN THIS%REQ = KREQ END IF IF (PRESENT(KNPROC)) THEN IF ( THIS%NPROC == 0 ) THEN THIS%NPROC = KNPROC ELSE IF ( KNPROC /= THIS%NPROC) THEN CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & Trying to update nproc > 0',& & LDABORT=LLABORT) END IF END IF END IF IF (PRESENT(KSEND_PT)) THEN IF (THIS%NPROC > 0 ) THEN ALLOCATE(THIS%SEND(THIS%NPROC)) KSEND_PT => THIS%SEND ELSE CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & Trying to allocate send displs but nproc == 0',& & LDABORT=LLABORT) END IF END IF IF (PRESENT(KRECV_PT)) THEN IF (THIS%NPROC > 0 ) THEN ALLOCATE(THIS%RECV(THIS%NPROC)) KRECV_PT => THIS%RECV ELSE CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & Trying to allocate recv displs but nproc == 0',& & LDABORT=LLABORT) END IF END IF THIS%PREV => NULL() END SUBROUTINE INITIALIZE FUNCTION GET_SEND(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), ALLOCATABLE :: R(:) R = THIS%SEND END FUNCTION GET_SEND FUNCTION GET_RECV(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), ALLOCATABLE :: R(:) R = THIS%RECV END FUNCTION GET_RECV FUNCTION GET_REQ(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM) R R = THIS%REQ END FUNCTION GET_REQ FUNCTION GET_NPROC(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM) R R = THIS%NPROC END FUNCTION GET_NPROC SUBROUTINE APPEND(THIS, KREQ, KNPROC, KSEND_PT, KRECV_PT, NO_NEW_NODE) CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KREQ, KNPROC INTEGER(KIND=JPIM), POINTER, INTENT(OUT), OPTIONAL :: KSEND_PT(:), KRECV_PT(:) LOGICAL, INTENT(IN), OPTIONAL :: NO_NEW_NODE TYPE(DISPLACEMENTS), POINTER :: YLNEW_NODE, YLTMP LOGICAL :: LLNEW_NODE IF(PRESENT(NO_NEW_NODE)) THEN LLNEW_NODE = .NOT. NO_NEW_NODE ELSE LLNEW_NODE = .TRUE. ENDIF IF (.NOT. ASSOCIATED(THIS%HEAD)) THEN IF (.NOT. LLNEW_NODE) THEN CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & APPEND called with NO_NEW_NODE=.TRUE.& & but the internal linked list is empty',& & LDABORT=LLABORT) END IF ALLOCATE(YLNEW_NODE) CALL YLNEW_NODE%INITIALIZE(KREQ,KNPROC,KSEND_PT,KRECV_PT) THIS%HEAD => YLNEW_NODE THIS%LIST_SIZE = THIS%LIST_SIZE + 1 ELSE IF (LLNEW_NODE) THEN ALLOCATE(YLNEW_NODE) CALL YLNEW_NODE%INITIALIZE(KREQ,KNPROC,KSEND_PT,KRECV_PT) YLNEW_NODE%PREV => THIS%HEAD THIS%HEAD => YLNEW_NODE THIS%LIST_SIZE = THIS%LIST_SIZE + 1 ELSE ! Update the curent head YLTMP => THIS%HEAD%PREV ! initialise sets prev to NULL CALL THIS%HEAD%INITIALIZE(KREQ,KNPROC,KSEND_PT,KRECV_PT) THIS%HEAD%PREV => YLTMP END IF END IF IF (THIS%LIST_SIZE > ITEST_SIZE) THEN WRITE(MPL_ERRUNIT,*) 'WARNING: rank ', MPL_RANK, 'The displacements list size ', & & THIS%LIST_SIZE, ' > ', ITEST_SIZE END IF END SUBROUTINE APPEND SUBROUTINE REMOVE_FIRST(THIS) CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS TYPE(DISPLACEMENTS), POINTER :: TMP IF (.NOT. ASSOCIATED(THIS%HEAD)) RETURN TMP => THIS%HEAD THIS%HEAD => THIS%HEAD%PREV DEALLOCATE(TMP) THIS%LIST_SIZE = THIS%LIST_SIZE - 1 END SUBROUTINE REMOVE_FIRST SUBROUTINE REMOVE_REQ1(THIS,KREQ) IMPLICIT NONE CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS INTEGER, INTENT(IN) :: KREQ TYPE(DISPLACEMENTS), POINTER :: YLCURRENT, YLCURRENT_, YLTMP YLCURRENT => THIS%HEAD DO WHILE (ASSOCIATED(YLCURRENT)) IF (YLCURRENT%REQ == KREQ) THEN IF ( ASSOCIATED(THIS%HEAD, YLCURRENT) ) THEN YLTMP => THIS%HEAD THIS%HEAD => THIS%HEAD%PREV YLCURRENT => THIS%HEAD ELSE YLTMP => YLCURRENT YLCURRENT => YLCURRENT%PREV YLCURRENT_%PREV => YLCURRENT END IF DEALLOCATE(YLTMP) THIS%LIST_SIZE = THIS%LIST_SIZE - 1 EXIT ELSE YLCURRENT_ => YLCURRENT YLCURRENT => YLCURRENT%PREV END IF ENDDO END SUBROUTINE REMOVE_REQ1 SUBROUTINE REMOVE_REQS(THIS,KREQ) IMPLICIT NONE CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), INTENT(IN) :: KREQ(:) INTEGER(KIND=JPIM), PARAMETER :: IMAX_WARNINGS = 10 INTEGER(KIND=JPIM), SAVE :: IWARNING = 0 TYPE(DISPLACEMENTS), POINTER :: CURRENT, CURRENT_, TMP INTEGER(KIND=JPIM) :: I LOGICAL :: LLFOUND IF (THIS%LIST_SIZE == 0) RETURN ! This subroutine can become a bottleneck if the request array grows large. ! This happens when point-to-point non-blocking communications are interleaved ! with a non-blocking collective (NBC) that lacks explicit displacement arrays. ! Since the MPI does not distingueshes between the requests for point to point or collective comms, ! the linked list must be checked by every mpl_wait call. ! To avoid this, the programmer should provide explicit displacement ! arrays for the NBC calls whose completion epoch overlaps with other non-blocking comms epochs. IF (IWARNING < IMAX_WARNINGS) THEN IF (SIZE(KREQ) > MAX(INT(0.1 * THIS%HEAD%NPROC), 10)) THEN WRITE(MPL_ERRUNIT,*) 'WARNING: FIAT::mpl_displs_container_mod.F90: rank ', & & MPL_RANK, 'REMOVE_REQ called with a request array of size ', & & SIZE(KREQ) IWARNING = IWARNING + 1 ENDIF ENDIF CURRENT => THIS%HEAD DO WHILE (ASSOCIATED(CURRENT)) LLFOUND = .FALSE. ! this loop order will pass unnecessarly over the removed requests ! but it does not scan the list multiple times DO I=1,SIZE(KREQ) IF (KREQ(I) == CURRENT%REQ) THEN IF ( ASSOCIATED(THIS%HEAD, CURRENT) ) THEN TMP => THIS%HEAD THIS%HEAD => THIS%HEAD%PREV CURRENT => THIS%HEAD ELSE CURRENT_%PREV => CURRENT%PREV TMP => CURRENT CURRENT => CURRENT%PREV END IF LLFOUND = .TRUE. DEALLOCATE(TMP) THIS%LIST_SIZE = THIS%LIST_SIZE - 1 EXIT END IF END DO IF (.NOT. LLFOUND) THEN CURRENT_ => CURRENT CURRENT => CURRENT%PREV END IF ENDDO END SUBROUTINE REMOVE_REQS SUBROUTINE CLEAR_LIST(THIS) CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS DO WHILE(ASSOCIATED(THIS%HEAD)) CALL THIS%REMOVE_FIRST() END DO END SUBROUTINE CLEAR_LIST SUBROUTINE PRINT_LIST(THIS) CLASS(LIST_MANAGER), INTENT(IN) :: THIS TYPE(DISPLACEMENTS), POINTER :: CURRENT CURRENT => THIS%HEAD WRITE(*,*)'-----------------' WRITE(*,*) 'Rank', MPL_RANK, 'List size ', THIS%LIST_SIZE DO WHILE(ASSOCIATED(CURRENT)) WRITE(*,*) 'REQUEST ', CURRENT%REQ IF (ALLOCATED(CURRENT%SEND)) WRITE(*,*) 'SEND DISPLS', CURRENT%SEND IF (ALLOCATED(CURRENT%RECV)) WRITE(*,*) 'RECV DISPLS', CURRENT%RECV CURRENT => CURRENT%PREV END DO WRITE(*,*)'-----------------' END SUBROUTINE PRINT_LIST END MODULE MPL_DISPLS_CONTAINER_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_bytes_mod.F900000664000175000017500000000261615157200431023632 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BYTES_MOD USE EC_PARKIND, ONLY : JPIM, JPIB, JPRM, JPRD IMPLICIT NONE PRIVATE PUBLIC :: MPL_BYTES INTERFACE MPL_BYTES MODULE PROCEDURE & & MPL_BYTES_IM, MPL_BYTES_IB, & & MPL_BYTES_RM, MPL_BYTES_RD END INTERFACE MPL_BYTES CONTAINS ! INTEGER*4 FUNCTION MPL_BYTES_IM(KVAR) INTEGER(KIND=JPIM), INTENT(IN) :: KVAR INTEGER(KIND=JPIM) MPL_BYTES_IM MPL_BYTES_IM = SIZE(TRANSFER(KVAR, (/'A'/))) END FUNCTION MPL_BYTES_IM ! INTEGER*8 FUNCTION MPL_BYTES_IB(KVAR) INTEGER(KIND=JPIB), INTENT(IN) :: KVAR INTEGER(KIND=JPIM) MPL_BYTES_IB MPL_BYTES_IB = SIZE(TRANSFER(KVAR, (/'A'/))) END FUNCTION MPL_BYTES_IB ! REAL*4 FUNCTION MPL_BYTES_RM(PVAR) REAL(KIND=JPRM), INTENT(IN) :: PVAR INTEGER(KIND=JPIM) MPL_BYTES_RM MPL_BYTES_RM = SIZE(TRANSFER(PVAR, (/'A'/))) END FUNCTION MPL_BYTES_RM ! REAL*8 FUNCTION MPL_BYTES_RD(PVAR) REAL(KIND=JPRD), INTENT(IN) :: PVAR INTEGER(KIND=JPIM) MPL_BYTES_RD MPL_BYTES_RD = SIZE(TRANSFER(PVAR, (/'A'/))) END FUNCTION MPL_BYTES_RD END MODULE MPL_BYTES_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_wait_mod.F900000664000175000017500000001702015157200431023443 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_WAIT_MOD !**** MPL_WAIT Waits for completion ! Purpose. ! -------- ! Returns control when the operation(s) identified by the request ! is completed. ! Normally used in conjunction with non-blocking buffering type !** Interface. ! ---------- ! CALL MPL_WAIT ! Input required arguments : ! ------------------------- ! KREQUEST - array or scalar containing ! Communication request(s) ! as provided by MPL_RECV or MPL_SEND ! Input optional arguments : ! ------------------------- ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KOUNT - must be the same size and shape as KREQUEST ! contains number of items sent/received ! KBYTES - number of bytes in a single element in all KOUNTs ! *must* be supplied with KOUNT ! KBYTES normally determited robustly by MPL_BYTES ! KERROR - return error code. If not supplied, ! MPL_WAIT aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! J. Hague: 2005-04-25 WAITALL replaced by WAIT loop ! F. Vana 05-Mar-2015 Support for single precision ! S. Saarinen 17-Feb-2017 Removed PBUF argument (not realy needed) ! KREQUEST must be INOUT (as per MPI_Wait) ! MPL_WAITS calls MPI_Waitall unless MPI1 ! S. Saarinen 01-Mar-2017 Added KBYTES ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPRM, JPIB USE MPL_MPI, ONLY : MPI_REQUEST, MPI_STATUS, MPI_BYTE USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE INTERFACE MPL_WAIT MODULE PROCEDURE MPL_WAITS, MPL_WAITS_INTEGERS, MPL_WAIT1, MPL_WAIT1_INTEGER END INTERFACE PUBLIC MPL_WAIT CONTAINS SUBROUTINE MPL_WAITS_INTEGERS(KREQUEST,KOUNT,KBYTES,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITALL => MPI_WAITALL8, MPI_GET_COUNT => MPI_GET_COUNT8, & MPI_WAIT => MPI_WAIT8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KREQUEST(:) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KOUNT(SIZE(KREQUEST)) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR TYPE(MPI_REQUEST) :: IREQUESTS_LOCAL(SIZE(KREQUEST)) IREQUESTS_LOCAL(:)%MPI_VAL=KREQUEST(:) CALL MPL_WAITS(IREQUESTS_LOCAL, CDSTRING=CDSTRING, KOUNT=KOUNT, KBYTES=KBYTES, KERROR=KERROR) KREQUEST(:)=IREQUESTS_LOCAL(:)%MPI_VAL END SUBROUTINE MPL_WAITS_INTEGERS SUBROUTINE MPL_WAITS(KREQUEST,KOUNT,KBYTES,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITALL => MPI_WAITALL8, MPI_GET_COUNT => MPI_GET_COUNT8, & MPI_WAIT => MPI_WAIT8 #endif TYPE(MPI_REQUEST), INTENT(INOUT) :: KREQUEST(:) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KOUNT(SIZE(KREQUEST)) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM) :: IWAITERR,ICOUNTERR,JL,IREQLEN,ICOUNT,IW TYPE(MPI_STATUS) :: IWAIT_STATUS(SIZE(KREQUEST)) INTEGER(KIND=JPIM) :: IREQUEST(SIZE(KREQUEST)) LOGICAL :: LLABORT LLABORT=.TRUE. IWAITERR=0 ICOUNTERR=0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAITS: MPL NOT INITIALISED ',LDABORT=LLABORT) IREQLEN=SIZE(KREQUEST) IREQUEST(:) = KREQUEST(:)%MPI_VAL #ifndef MPI1 CALL MPI_WAITALL(IREQLEN,KREQUEST,IWAIT_STATUS,IWAITERR) #else DO JL=1,IREQLEN CALL MPI_WAIT(KREQUEST(JL),IWAIT_STATUS(1,JL),IW) IWAITERR=MAX(IWAITERR,IW) ENDDO #endif IF(PRESENT(KOUNT))THEN IF (.NOT.PRESENT(KBYTES)) THEN CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: KBYTES MUST BE PRESENT WITH KOUNT ', & & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF IF(SIZE(KOUNT) /= IREQLEN) THEN CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: KOUNT AND KREQUEST INCONSISTENT ', & & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF DO JL=1,IREQLEN CALL MPI_GET_COUNT(IWAIT_STATUS(JL),MPI_BYTE,KOUNT(JL),ICOUNTERR) KOUNT(JL) = KOUNT(JL) / KBYTES ENDDO ENDIF IF(PRESENT(KERROR))THEN KERROR=IWAITERR+ICOUNTERR ELSE IF(IWAITERR /= 0) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_WAITS_WAITING',CDSTRING=CDSTRING,KERROR=IWAITERR,LDABORT=LLABORT) ELSE IF(ICOUNTERR /= 0) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_WAITS_COUNT',CDSTRING=CDSTRING,KERROR=ICOUNTERR,LDABORT=LLABORT) ENDIF ! DELETE THE NON-BLOCKING COLLECTIVES DISPLACEMENTS ARRAYS CALL YDDISPLS_LIST%REMOVE_REQ(IREQUEST) RETURN END SUBROUTINE MPL_WAITS SUBROUTINE MPL_WAIT1_INTEGER(KREQUEST,KOUNT,KBYTES,KERROR,CDSTRING) INTEGER(KIND=JPIM),INTENT(INOUT) :: KREQUEST CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KOUNT INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR TYPE(MPI_REQUEST) :: IREQUEST_LOCAL IREQUEST_LOCAL%MPI_VAL=KREQUEST CALL MPL_WAIT1(IREQUEST_LOCAL, CDSTRING=CDSTRING, KOUNT=KOUNT, KBYTES=KBYTES, KERROR=KERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL END SUBROUTINE MPL_WAIT1_INTEGER SUBROUTINE MPL_WAIT1(KREQUEST,KOUNT,KBYTES,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITALL => MPI_WAITALL8, MPI_GET_COUNT => MPI_GET_COUNT8 #endif TYPE(MPI_REQUEST), INTENT(INOUT) :: KREQUEST CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KOUNT INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM) :: IWAITERR,ICOUNTERR,JL,IREQLEN,ICOUNT TYPE(MPI_STATUS) :: IWAIT_STATUS INTEGER(KIND=JPIM) :: IREQUEST LOGICAL :: LLABORT LLABORT=.TRUE. IWAITERR=0 ICOUNTERR=0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: MPL NOT INITIALISED ',LDABORT=LLABORT) IREQUEST=KREQUEST%MPI_VAL CALL MPI_WAIT(KREQUEST,IWAIT_STATUS,IWAITERR) ! DELETE THE NON-BLOCKING COLLECTIVES DISPLACEMENTS ARRAYS, IF THE WAIT IS ON THEM CALL YDDISPLS_LIST%REMOVE_REQ(IREQUEST) IF(PRESENT(KOUNT))THEN IF (.NOT.PRESENT(KBYTES)) THEN CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: KBYTES MUST BE PRESENT WITH KOUNT ', & & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF CALL MPI_GET_COUNT(IWAIT_STATUS,MPI_BYTE,KOUNT,ICOUNTERR) KOUNT = KOUNT / KBYTES ENDIF IF(PRESENT(KERROR))THEN KERROR=IWAITERR+ICOUNTERR ELSE IF(IWAITERR /= 0) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_WAIT_WAITING',CDSTRING=CDSTRING,KERROR=IWAITERR,LDABORT=LLABORT) ELSE IF(ICOUNTERR /= 0) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_WAIT_COUNT',CDSTRING=CDSTRING,KERROR=ICOUNTERR,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_WAIT1 END MODULE MPL_WAIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_read_mod.F900000664000175000017500000002035715157200431023421 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_READ_MOD ! ! Purpose. read from an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_read(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kfptr - handle for file ! kop - requested operation ! kbuf - buffer containing data to be written ! klen - length of buffer in words ! input/output arguements: ! kreq - request handle for non-blocking operations ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-11 ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND, ONLY : JPIM, JPRM USE MPL_MPI, ONLY : MPI_REQUEST, MPI_FILE, MPI_STATUS, MPI_INTEGER, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO, MPL_IOP IMPLICIT NONE INTERFACE MPL_READ MODULE PROCEDURE MPL_READ_INT,MPL_READ_REAL8 END INTERFACE PRIVATE PUBLIC MPL_READ CONTAINS SUBROUTINE MPL_READ_INT(KFPTR,KOP,KBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_READ_SHARED => MPI_FILE_READ_SHARED8, & MPI_FILE_READ_ORDERED => MPI_FILE_READ_ORDERED8, & MPI_FILE_IREAD_SHARED => MPI_FILE_IREAD_SHARED8, & MPI_FILE_READ_ORDERED_BEGIN => MPI_FILE_READ_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, MPI_FILE_READ_ORDERED_END => MPI_FILE_READ_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) :: KBUF(:) TYPE(MPI_REQUEST) :: KREQ TYPE(MPI_FILE) :: KFPTR_LOCAL TYPE(MPI_STATUS) :: STATUS KFPTR_LOCAL%MPI_VAL=KFPTR ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking read, non collective, shared file pointer CALL MPI_FILE_READ_SHARED(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking read, non collective, shared file pointer CALL MPI_FILE_IREAD_SHARED(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED_BEGIN(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_READ_ORDERED_END(KFPTR_LOCAL,& & KBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF #else CALL ABOR1('MPL_READ_INT not build with MPI2') #endif ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_READ_INT SUBROUTINE MPL_READ_REAL8(KFPTR,KOP,PBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_READ_SHARED => MPI_FILE_READ_SHARED8, & MPI_FILE_READ_ORDERED => MPI_FILE_READ_ORDERED8, & MPI_FILE_IREAD_SHARED => MPI_FILE_IREAD_SHARED8, & MPI_FILE_READ_ORDERED_BEGIN => MPI_FILE_READ_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, MPI_FILE_READ_ORDERED_END => MPI_FILE_READ_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR REAL(KIND=JPRM) :: PBUF(:) TYPE(MPI_REQUEST) :: KREQ TYPE(MPI_FILE) :: KFPTR_LOCAL TYPE(MPI_STATUS) :: STATUS KFPTR_LOCAL%MPI_VAL=KFPTR ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking read, non collective, shared file pointer CALL MPI_FILE_READ_SHARED(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking read, non collective, shared file pointer CALL MPI_FILE_IREAD_SHARED(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED_BEGIN(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_READ_ORDERED_END(KFPTR_LOCAL,& & PBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF ! ! ----------------------------------------------------------------- #else CALL ABOR1('MPL_READ_REAL8 not build with MPI2') #endif RETURN END SUBROUTINE MPL_READ_REAL8 END MODULE MPL_READ_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_broadcast_mod.F900000664000175000017500000011736515157200431024456 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BROADCAST_MOD !**** MPL_BROADCAST Message broadcast ! Purpose. ! -------- ! Broadcasts a message from the process with rank root ! to all processes in the group. !** Interface. ! ---------- ! CALL MPL_BROADCAST ! Input required arguments : ! ------------------------- ! PBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KTAG - message tag ! Input optional arguments : ! ------------------------- ! KROOT - number of root process (default=1) ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_BROADCAST aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud, S.Saarinen ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P.Marguinaud : 2012-04-13 : Cleaning & refactor PREAMB1 ! P.Marguinaud : 2012-09-11 : Add MPL_BROADCAST_LOGICAL1 ! M.Hamrud : 2014-10-22 : Add nonblocking option ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_REQUEST, MPI_REAL4, MPI_REAL8, MPI_INTEGER, MPI_INTEGER8, MPI_BYTE, MPI_LOGICAL USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_COMM_OML, MPL_RANK, MPL_METHOD, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_MYRANK_MOD, ONLY : MPL_MYRANK IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_BROADCAST MODULE PROCEDURE MPL_BROADCAST_REAL4,MPL_BROADCAST_REAL8, & & MPL_BROADCAST_REAL42,MPL_BROADCAST_REAL43,MPL_BROADCAST_REAL44,& & MPL_BROADCAST_REAL82,MPL_BROADCAST_REAL83,MPL_BROADCAST_REAL84,& & MPL_BROADCAST_REAL4_SCALAR,MPL_BROADCAST_REAL8_SCALAR, & & MPL_BROADCAST_INT,MPL_BROADCAST_INT2,MPL_BROADCAST_INT3,MPL_BROADCAST_INT_SCALAR, & & MPL_BROADCAST_LONG, & & MPL_BROADCAST_CHAR_SCALAR, MPL_BROADCAST_CHAR1, & & MPL_BROADCAST_LOGICAL_SCALAR, MPL_BROADCAST_LOGICAL1 END INTERFACE PUBLIC MPL_BROADCAST CONTAINS SUBROUTINE MPL_BROADCAST_PREAMB1(KROOTR,KCOMMR,KPL_NUMPROC,KPL_MYRANK,KMP_TYPER,LDRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(OUT) :: KROOTR INTEGER(KIND=JPIM),INTENT(OUT) :: KCOMMR INTEGER(KIND=JPIM),INTENT(OUT) :: KPL_NUMPROC INTEGER(KIND=JPIM),INTENT(OUT) :: KPL_MYRANK INTEGER(KIND=JPIM),INTENT(OUT) :: KMP_TYPER LOGICAL, INTENT(OUT) :: LDRETURN INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KMP_TYPE TYPE(MPI_COMM) :: KCOMMR_LOCAL INTEGER(KIND=JPIM) :: IERROR INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IERROR = 0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_BROADCAST: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN KCOMMR=KCOMM ELSE KCOMMR=MPL_COMM_OML(ITID) ENDIF IF(KCOMMR == MPL_COMM_OML(ITID)) THEN KPL_NUMPROC = MPL_NUMPROC KPL_MYRANK = MPL_RANK ELSE KCOMMR_LOCAL%MPI_VAL=KCOMMR CALL MPI_COMM_SIZE(KCOMMR_LOCAL,KPL_NUMPROC,IERROR) KPL_MYRANK = MPL_MYRANK(KCOMMR) ENDIF IF(PRESENT(KROOT)) THEN KROOTR=KROOT ELSE KROOTR=1 ENDIF IF(PRESENT(KMP_TYPE)) THEN KMP_TYPER=KMP_TYPE ELSE KMP_TYPER=MPL_METHOD ENDIF IF (PRESENT (KERROR)) KERROR = IERROR IF (KPL_NUMPROC == 1) THEN IF(PRESENT(KERROR)) THEN KERROR=0 ENDIF LDRETURN=.TRUE. ELSE LDRETURN=.FALSE. ENDIF END SUBROUTINE MPL_BROADCAST_PREAMB1 SUBROUTINE MPL_BROADCAST_REAL4(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRM) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL4 SUBROUTINE MPL_BROADCAST_REAL8(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) ! Passing PBUF(1) here causes incorrect results on IBM IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL8 SUBROUTINE MPL_BROADCAST_REAL42(PBUF,KTAG,KROOT,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) REAL(KIND=JPRM) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL42 SUBROUTINE MPL_BROADCAST_REAL43(PBUF,KTAG,KROOT,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) REAL(KIND=JPRM) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT> IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL43 SUBROUTINE MPL_BROADCAST_REAL44(PBUF,KTAG,KROOT,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) REAL(KIND=JPRM) :: PBUF(:,:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT> IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL44 SUBROUTINE MPL_BROADCAST_REAL82(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL82 SUBROUTINE MPL_BROADCAST_REAL83(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL83 SUBROUTINE MPL_BROADCAST_REAL84(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:,:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL84 SUBROUTINE MPL_BROADCAST_REAL4_SCALAR(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRM) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL4,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL4_SCALAR SUBROUTINE MPL_BROADCAST_REAL8_SCALAR(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL8_SCALAR SUBROUTINE MPL_BROADCAST_LONG(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIB) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,MPI_INTEGER8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,MPI_INTEGER8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_LONG SUBROUTINE MPL_BROADCAST_INT(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIM) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT SUBROUTINE MPL_BROADCAST_INT2(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) INTEGER(KIND=JPIM) :: KBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT2 SUBROUTINE MPL_BROADCAST_INT3(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) INTEGER(KIND=JPIM) :: KBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT3 SUBROUTINE MPL_BROADCAST_INT_SCALAR(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIM) :: KBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT_SCALAR SUBROUTINE MPL_BROADCAST_CHAR_SCALAR(CDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif CHARACTER(LEN=*) :: CDBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = LEN(CDBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(CDBUF,ICOUNT,MPI_BYTE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(CDBUF,ICOUNT,MPI_BYTE,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_CHAR_SCALAR SUBROUTINE MPL_BROADCAST_CHAR1(CDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif CHARACTER(LEN=*) :: CDBUF (:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = LEN(CDBUF)*SIZE(CDBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(CDBUF,ICOUNT,MPI_BYTE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(CDBUF,ICOUNT,MPI_BYTE,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_CHAR1 SUBROUTINE MPL_BROADCAST_LOGICAL_SCALAR(LDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif LOGICAL :: LDBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(LDBUF,ICOUNT,MPI_LOGICAL,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST(LDBUF,ICOUNT,MPI_LOGICAL,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_LOGICAL_SCALAR SUBROUTINE MPL_BROADCAST_LOGICAL1(LDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif LOGICAL :: LDBUF (:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM%MPI_VAL,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE (LDBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST (LDBUF,ICOUNT,MPI_LOGICAL,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' KREQUEST MISSING',KERROR=KERROR,LDABORT=LLABORT) CALL MPI_IBCAST (LDBUF,ICOUNT,MPI_LOGICAL,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF CALL MPL_RECVSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_LOGICAL1 END MODULE MPL_BROADCAST_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_nproc_mod.F900000664000175000017500000000321115157200431023615 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_NPROC_MOD !**** MPL_NPROC - return Number of processes ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND,ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM,MPI_COMM_SIZE USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_NPROC CONTAINS FUNCTION MPL_NPROC(KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM) :: MPL_NPROC INTEGER(KIND=JPIM) :: IERROR,IPROC LOGICAL :: LLABORT=.TRUE. TYPE(MPI_COMM) :: KCOMM_LOCAL IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_MYRANK: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN KCOMM_LOCAL%MPI_VAL=KCOMM CALL MPI_COMM_SIZE(KCOMM_LOCAL,IPROC,IERROR) MPL_NPROC = IPROC ELSE MPL_NPROC = MPL_NUMPROC ENDIF END FUNCTION MPL_NPROC END MODULE MPL_NPROC_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_comm_split_mod.F900000664000175000017500000000255715157200431024656 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_SPLIT_MOD !**** *MPL_COMM_SPLIT* - Split a communicator ! Author. ! ------- ! Philippe Marguinaud *METEO FRANCE* ! Original : 11-09-2012 USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_UNDEFINED, MPI_COMM IMPLICIT NONE PRIVATE PUBLIC MPL_COMM_SPLIT CONTAINS SUBROUTINE MPL_COMM_SPLIT (KCOMM, KCOLOR, KKEY, KNEWCOMM, KERROR, CDSTRING) INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM INTEGER (KIND=JPIM), INTENT (IN) :: KCOLOR INTEGER (KIND=JPIM), INTENT (IN) :: KKEY INTEGER (KIND=JPIM), INTENT (OUT) :: KNEWCOMM INTEGER (KIND=JPIM), INTENT (OUT) :: KERROR CHARACTER (LEN=*), OPTIONAL, INTENT (IN) :: CDSTRING INTEGER (KIND=JPIM) :: ICOLOR TYPE(MPI_COMM) :: LOCALCOMM,LOCALCOMM_NEW ICOLOR=KCOLOR IF(ICOLOR<0) ICOLOR=MPI_UNDEFINED LOCALCOMM%MPI_VAL=KCOMM CALL MPI_COMM_SPLIT (LOCALCOMM, ICOLOR, KKEY, LOCALCOMM_NEW, KERROR) KNEWCOMM=LOCALCOMM_NEW%MPI_VAL END SUBROUTINE MPL_COMM_SPLIT END MODULE MPL_COMM_SPLIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_mygatherv_mod.F900000664000175000017500000000271615157200431024513 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MYGATHERV_MOD USE EC_PARKIND ,ONLY : JPRD, JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_REAL8 USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_MYGATHERV LOGICAL :: LLABORT=.TRUE. CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_MYGATHERV(PSEND,KSEND,PRECV,KRECV,KDISPL,KROOT,KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif REAL(KIND=JPRD), INTENT(IN) :: PSEND(:) REAL(KIND=JPRD), INTENT(OUT) :: PRECV(:) INTEGER(KIND=JPIM), INTENT(IN) :: KSEND, KRECV(:), KDISPL(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT, KCOMM INTEGER(KIND=JPIM) :: IERR TYPE(MPI_COMM) :: KCOMM_LOCAL KCOMM_LOCAL%MPI_VAL=KCOMM CALL MPI_GATHERV(PSEND,KSEND,MPI_REAL8, & & PRECV,KRECV,KDISPL,MPI_REAL8,KROOT-1,KCOMM_LOCAL,IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_MYGATHERV',KERROR=IERR,LDABORT=LLABORT) END SUBROUTINE MPL_MYGATHERV ! ------------------------------------------------------------------ END MODULE MPL_MYGATHERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_myrank_mod.F900000664000175000017500000000437515157200431024011 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MYRANK_MOD !**** MPL_MYRANK - Find rank ! Purpose. ! -------- ! Returns the rank of the calling process ! in the currently active communicator !** Interface. ! ---------- ! IRANK=MPL_MYRANK(KCOMM) ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! Input required arguments : ! ------------------------- ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM USE MPL_DATA_MODULE, ONLY : MPL_RANK, MPL_NUMPROC, MPL_RANK USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_MYRANK CONTAINS FUNCTION MPL_MYRANK(KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_RANK => MPI_COMM_RANK8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM) :: MPL_MYRANK INTEGER(KIND=JPIM) :: IRANK,IERROR,ICOMM LOGICAL :: LLABORT=.TRUE. TYPE(MPI_COMM) :: KCOMM_LOCAL IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_MYRANK: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN KCOMM_LOCAL%MPI_VAL=KCOMM CALL MPI_COMM_RANK(KCOMM_LOCAL, IRANK, IERROR) IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_MYRANK: ERROR FROM MPI_COMM_RANK',KERROR=IERROR) MPL_MYRANK=IRANK+1 ELSE MPL_MYRANK=MPL_RANK ENDIF END FUNCTION MPL_MYRANK END MODULE MPL_MYRANK_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_gatherv_mod.F900000664000175000017500000005644315157200431024153 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_GATHERV_MOD !**** MPL_GATHERV Gather data to specific processor ! Purpose. ! -------- ! Gather data to specific processor ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_GATHERV ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PRECVBUF - buffer containing message (required from kroot) ! (can be type REAL*4, REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! (required from kroot processor) ! Input optional arguments : ! ------------------------- ! KROOT - rank of receiveing processor (default 1) ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_GATHERV aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-11-23 ! M.Hamrud: 2014-10-22 : Add nonblocking option ! F.Vana: 2015-03-05 : Support for single precision ! P.Gillies: 2018-06-25 : Add SENDCOUNT argument, needed for zero-length sends ! --- *NOT* THREAD SAFE YET --- ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_DATATYPE, MPI_REQUEST, MPI_REAL4, MPI_REAL8, MPI_INTEGER, MPI_CHARACTER USE MPL_DATA_MODULE, ONLY : MPL_RANK, MPL_METHOD, MPL_ERRUNIT, MPL_COMM_OML, MPL_NUMPROC, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_MYRANK_MOD, ONLY : MPL_MYRANK USE MPL_WAIT_MOD, ONLY : MPL_WAIT USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. REAL(KIND=JPRD) :: ZDUM_JPRD REAL(KIND=JPRM) :: ZDUM_JPRM CHARACTER :: ZDUM_CHAR(1) INTEGER(KIND=JPIM) :: ZDUM_INT INTEGER(KIND=JPIM), ALLOCATABLE :: ONES(:) INTERFACE MPL_GATHERV MODULE PROCEDURE MPL_GATHERV_REAL8,MPL_GATHERV_REAL4,MPL_GATHERV_CHAR_SCALAR,& & MPL_GATHERV_INT,MPL_GATHERV_INT_SCALAR END INTERFACE PUBLIC MPL_GATHERV CONTAINS SUBROUTINE MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE, & & KCOMM,KROOT,KMP_TYPE,KREQUEST) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(OUT) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE,KREQUEST INTEGER(KIND=JPIM) :: ITID TYPE(MPI_COMM) :: ICOMM_LOCAL ITID = OML_MY_THREAD() IERROR = 0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_GATHERV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(ICOMM == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC IPL_MYRANK = MPL_RANK ELSE ICOMM_LOCAL%MPI_VAL=ICOMM CALL MPI_COMM_SIZE(ICOMM_LOCAL,IPL_NUMPROC,IERROR) IPL_MYRANK = MPL_MYRANK(ICOMM) ENDIF IF (.NOT. ALLOCATED(ONES)) THEN ALLOCATE(ONES(IPL_NUMPROC)) ONES(:) = 1_JPIM ENDIF IF(PRESENT(KROOT)) THEN IROOT=KROOT ELSE IROOT=1 ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: KREQUEST MISSING',LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_PREAMB1 SUBROUTINE MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & KRECVCOUNTS,KIRECVDISPL,KIRECVDISPL_PT,IMP_TYPE,KRECVDISPL,CDSTRING) INTEGER(KIND=JPIM),INTENT(IN) :: IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),ALLOCATABLE,TARGET,INTENT(OUT) :: KIRECVDISPL(:) INTEGER(KIND=JPIM), POINTER, INTENT(OUT) :: KIRECVDISPL_PT(:) INTEGER(KIND=JPIM),INTENT(IN) :: IMP_TYPE INTEGER(KIND=JPIM),INTENT(IN),TARGET,OPTIONAL :: KRECVDISPL(:) CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IR IF(SIZE(KRECVCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_GATHERV: ERROR KRECVCOUNTS DIMENSION=',& & SIZE(KRECVCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_GATHERV: ERROR KRECVCOUNTS DIMENSION IS WRONG',LDABORT=LLABORT) ENDIF IF(ISENDCOUNT /= KRECVCOUNTS(IPL_MYRANK)) THEN WRITE(MPL_ERRUNIT,*)'MPL_GATHERV: ERROR KRECVCOUNTS INCONSISTENCY ',& & ISENDCOUNT,KRECVCOUNTS(IPL_MYRANK) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_GATHERV: ERROR ISENDCOUNT /= KRECVCOUNTS(MPL_RANK) ',LDABORT=LLABORT) ENDIF IF(PRESENT(KRECVDISPL)) THEN KIRECVDISPL_PT => KRECVDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC, KRECV_PT=KIRECVDISPL_PT) ELSE ALLOCATE(KIRECVDISPL(IPL_NUMPROC)) KIRECVDISPL_PT => KIRECVDISPL END IF KIRECVDISPL_PT(1) = 0 DO IR=2, IPL_NUMPROC KIRECVDISPL_PT(IR) = KIRECVDISPL_PT(IR-1) + KRECVCOUNTS(IR-1) ENDDO ENDIF DO IR=1, IPL_NUMPROC IF(KIRECVDISPL_PT(IR)+KRECVCOUNTS(IR) > IRECVBUFSIZE) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_GATHERV:RECV BUFFER TOO SMALL ', & & IR,KIRECVDISPL_PT(IR),KRECVCOUNTS(IR),IRECVBUFSIZE CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV',CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF ENDDO END SUBROUTINE MPL_GATHERV_PREAMB2 SUBROUTINE MPL_GATHERV_REAL4(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif REAL(KIND=JPRM),INTENT(IN) :: PSENDBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT REAL(KIND=JPRM),INTENT(OUT),OPTIONAL :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT TYPE(MPI_DATATYPE) :: IDATA_TYPE TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL LOGICAL :: LLPRESENT_RECVBUF IDATA_TYPE=MPI_REAL4 LLPRESENT_RECVBUF=PRESENT(PRECVBUF) #include "mpl_gatherv_array_tmpl.i90" END SUBROUTINE MPL_GATHERV_REAL4 SUBROUTINE MPL_GATHERV_REAL8(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif REAL(KIND=JPRD) :: PSENDBUF(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KROOT REAL(KIND=JPRD), INTENT(INOUT),OPTIONAL :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT INTEGER(KIND=JPIM) :: IDUM,IST,IEND,JK TYPE(MPI_DATATYPE) :: IDATA_TYPE TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL LOGICAL :: LLPRESENT_RECVBUF IDATA_TYPE=MPI_REAL8 LLPRESENT_RECVBUF=PRESENT(PRECVBUF) #include "mpl_gatherv_array_tmpl.i90" END SUBROUTINE MPL_GATHERV_REAL8 SUBROUTINE MPL_GATHERV_INT(KSENDBUF,KROOT,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif INTEGER(KIND=JPIM),TARGET,INTENT(IN) :: KSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KROOT INTEGER(KIND=JPIM),TARGET,INTENT(OUT),OPTIONAL :: KRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KRECVCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KSENDCOUNT,KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM), INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT TYPE(MPI_DATATYPE) :: IDATA_TYPE TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL LOGICAL :: LLPRESENT_RECVBUF IDATA_TYPE=MPI_INTEGER LLPRESENT_RECVBUF=PRESENT(KRECVBUF) IF (PRESENT(KRECVBUF)) THEN ASSOCIATE(PSENDBUF=>KSENDBUF,PRECVBUF=>KRECVBUF) #include "mpl_gatherv_array_tmpl.i90" END ASSOCIATE ELSE ASSOCIATE(PSENDBUF=>KSENDBUF,PRECVBUF=>KSENDBUF) #include "mpl_gatherv_array_tmpl.i90" END ASSOCIATE END IF END SUBROUTINE MPL_GATHERV_INT SUBROUTINE MPL_GATHERV_CHAR_SCALAR(CSENDBUF,KROOT,CRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif CHARACTER(LEN=*) :: CSENDBUF INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT CHARACTER(LEN=*),OPTIONAL :: CRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT INTEGER(KIND=JPIM) :: IDUM,IST,IEND,JK !,ICOUNT TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT=KSENDCOUNT ELSE ISENDCOUNT = LEN(CSENDBUF) ENDIF CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM%MPI_VAL, & & IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. PRESENT(CRECVBUF)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = LEN(CRECVBUF)*SIZE(CRECVBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(CRECVBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & KRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(CSENDBUF,ISENDCOUNT,MPI_CHARACTER,CRECVBUF,KRECVCOUNTS,& & IRECVDISPL_PT,MPI_CHARACTER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(CSENDBUF,ISENDCOUNT,MPI_CHARACTER,CRECVBUF,KRECVCOUNTS,& & IRECVDISPL_PT,MPI_CHARACTER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_CHARACTER%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_CHARACTER%MPI_VAL) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(CSENDBUF,ISENDCOUNT,MPI_CHARACTER,ZDUM_CHAR,ONES, & & ONES,MPI_CHARACTER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(CSENDBUF,ISENDCOUNT,MPI_CHARACTER,ZDUM_CHAR,ONES, & & ONES,MPI_CHARACTER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_CHARACTER%MPI_VAL) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_GATHERV',CDSTRING=CDSTRING,& & KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_CHAR_SCALAR SUBROUTINE MPL_GATHERV_INT_SCALAR(KSENDBUF,KROOT,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,& & KMP_TYPE,KRECVDISPL,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8, MPI_GATHER => MPI_GATHER8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KSENDBUF INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IRECVCOUNTS(MPL_NUMPROC) INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT=KSENDCOUNT ELSE ISENDCOUNT = 1 ENDIF IF(PRESENT(KRECVCOUNTS)) THEN IRECVCOUNTS=KRECVCOUNTS ELSE IRECVCOUNTS(:) = 1 ENDIF CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM%MPI_VAL,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. PRESENT(KRECVBUF)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = SIZE(KRECVBUF) IF(PRESENT(KRECVDISPL).OR.PRESENT(KSENDCOUNT)) THEN IF(.NOT.PRESENT(KSENDCOUNT)) THEN IRECVCOUNTS(:) = 1 ENDIF CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & IRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,& & IRECVCOUNTS,IRECVDISPL_PT,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,& & IRECVCOUNTS,IRECVDISPL_PT,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) CALL MPL_RECVSTATS(SUM(IRECVCOUNTS),MPI_INTEGER%MPI_VAL) ENDIF ELSE IF(IRECVBUFSIZE < IPL_NUMPROC) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV:IRECVBUFSIZE < IPL_NUMPROC',& & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,& & ISENDCOUNT,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(KSENDBUF,ISENDCOUNT,MPI_INTEGER,KRECVBUF,& & ISENDCOUNT,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL CALL MPL_WAIT(IREQUEST_LOCAL) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) ENDIF ENDIF ELSE IF(PRESENT(KRECVDISPL).OR.PRESENT(KSENDCOUNT)) THEN IF(.NOT.PRESENT(KSENDCOUNT)) THEN IRECVCOUNTS(:)=1 ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,ZDUM_INT,KRECVBUF, & & IRECVCOUNTS,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(KSENDBUF,ISENDCOUNT,MPI_INTEGER,ZDUM_INT,ONES, & & ONES,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL CALL MPL_WAIT(IREQUEST_LOCAL) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(KSENDBUF,ISENDCOUNT,MPI_INTEGER,ZDUM_INT,& & 1,MPI_INTEGER,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(KSENDBUF,ISENDCOUNT,MPI_INTEGER,ZDUM_INT,& & 1,MPI_INTEGER,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) ENDIF ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_INT_SCALAR SUBROUTINE MPL_GATHERV_REAL8_SCALAR(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,& & KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8, MPI_GATHER => MPI_GATHER8 #endif REAL(KIND=JPRD),INTENT(IN) :: PSENDBUF INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT REAL(KIND=JPRD),INTENT(OUT),OPTIONAL :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:) ! Not used; for compatibility only INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IRECVCOUNTS(MPL_NUMPROC) INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,IROOT,IMP_TYPE TYPE(MPI_COMM) :: ICOMM TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT ISENDCOUNT = 1 CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM%MPI_VAL,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. PRESENT(PRECVBUF)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = SIZE(PRECVBUF) IF(PRESENT(KRECVDISPL)) THEN IRECVCOUNTS(:) = 1 CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & IRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL8,PRECVBUF,& & IRECVCOUNTS,IRECVDISPL_PT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL8,PRECVBUF,& & IRECVCOUNTS,IRECVDISPL_PT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) CALL MPL_RECVSTATS(SUM(IRECVCOUNTS),MPI_REAL8%MPI_VAL) ENDIF ELSE IF(IRECVBUFSIZE < IPL_NUMPROC) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV:IRECVBUFSIZE < IPL_NUMPROC',& & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(PSENDBUF,ISENDCOUNT,MPI_REAL8,PRECVBUF,& & ISENDCOUNT,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(PSENDBUF,ISENDCOUNT,MPI_REAL8,PRECVBUF,& & ISENDCOUNT,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL CALL MPL_WAIT(IREQUEST_LOCAL) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) ENDIF ENDIF ELSE IF(PRESENT(KRECVDISPL)) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL8,ZDUM_JPRD,ONES, & & ONES,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF,ISENDCOUNT,MPI_REAL8,ZDUM_JPRD,ONES, & & ONES,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(PSENDBUF,ISENDCOUNT,MPI_REAL8,ZDUM_JPRD,& & 1,MPI_REAL8,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(PSENDBUF,ISENDCOUNT,MPI_REAL8,ZDUM_JPRD,& & 1,MPI_REAL8,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) ENDIF ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_REAL8_SCALAR END MODULE MPL_GATHERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_groups.F900000664000175000017500000001121515157200431023157 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_GROUPS ! Purpose. ! -------- ! Use MPI groups for easier to read code (and more efficient ! communications, at least on IBM). ! Author. ! ------- ! Y. Tremolet ! Modifications. ! -------------- ! Original: 02-03-13 ! ------------------------------------------------------------------ ! --- *NOT* THREAD SAFE YET --- USE EC_PARKIND ,ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_GROUP USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_COMM_GRID, MPL_ALL_LEVS_COMM, MPL_ALL_MS_COMM, & & MPL_GROUPS_CREATE, MPL_CART_RANK, MPL_CART_COORDS INTEGER(KIND=JPIM) :: MPL_ALL_LEVS_COMM,MPL_ALL_MS_COMM LOGICAL,SAVE :: LGROUPSETUP=.FALSE. #ifdef _CRAYFTN INTEGER(KIND=JPIM) :: MPL_COMM_GRID, MPL_GP_GRID #else TYPE(MPI_COMM) :: MPL_COMM_GRID !! internal use only, so can have native MPI type TYPE(MPI_GROUP) :: MPL_GP_GRID !! internal use only, so can have native MPI type #endif CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_GROUPS_CREATE(KPROCW, KPROCV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_CART_CREATE => MPI_CART_CREATE8, MPI_COMM_GROUP => MPI_COMM_GROUP8, & MPI_CART_SUB => MPI_CART_SUB8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KPROCW, KPROCV INTEGER(KIND=JPIM) :: IDIMS(2), IERR LOGICAL :: LTORUS(2), LDIMS(2), LREORDER #ifdef _CRAYFTN INTEGER(KIND=JPIM) :: MPL_LCOMM INTEGER(KIND=JPIM) :: MPL_ALL_LEVS_COMM_INTERNAL, MPL_ALL_MS_COMM_INTERNAL #else TYPE(MPI_COMM) :: MPL_LCOMM TYPE(MPI_COMM) :: MPL_ALL_LEVS_COMM_INTERNAL, MPL_ALL_MS_COMM_INTERNAL #endif IF(LGROUPSETUP) RETURN IDIMS(1)=KPROCW IDIMS(2)=KPROCV LTORUS(1)=.FALSE. LTORUS(2)=.FALSE. LREORDER=.FALSE. #ifdef _CRAYFTN MPL_LCOMM = MPL_COMM_OML(1) #else MPL_LCOMM%MPI_VAL = MPL_COMM_OML(1) #endif CALL MPI_CART_CREATE(MPL_LCOMM, 2, IDIMS, LTORUS, LREORDER, & & MPL_COMM_GRID, IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_GROUPS_CREATE: MPI_CART_CREATE',KERROR=IERR) CALL MPI_COMM_GROUP(MPL_COMM_GRID, MPL_GP_GRID, IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_GROUPS_CREATE: mpi_comm_group',KERROR=IERR) ! Group all levels for same Ms ! ---------------------------- LDIMS(1)=.FALSE. LDIMS(2)=.TRUE. CALL MPI_CART_SUB(MPL_COMM_GRID, LDIMS, MPL_ALL_LEVS_COMM_INTERNAL, IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_GROUPS_CREATE: mpi_cart_sub 1',KERROR=IERR) #ifdef _CRAYFTN MPL_ALL_LEVS_COMM=MPL_ALL_LEVS_COMM_INTERNAL #else MPL_ALL_LEVS_COMM=MPL_ALL_LEVS_COMM_INTERNAL%MPI_VAL #endif ! Group all Ms for same levels ! ---------------------------- LDIMS(1)=.TRUE. LDIMS(2)=.FALSE. CALL MPI_CART_SUB(MPL_COMM_GRID, LDIMS, MPL_ALL_MS_COMM_INTERNAL, IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_GROUPS_CREATE: mpi_cart_sub 2',KERROR=IERR) #ifdef _CRAYFTN MPL_ALL_MS_COMM=MPL_ALL_MS_COMM_INTERNAL #else MPL_ALL_MS_COMM=MPL_ALL_MS_COMM_INTERNAL%MPI_VAL #endif LGROUPSETUP=.TRUE. END SUBROUTINE MPL_GROUPS_CREATE ! ------------------------------------------------------------------ FUNCTION MPL_CART_RANK(KPROCW, KPROCV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_CART_RANK => MPI_CART_RANK8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KPROCW, KPROCV INTEGER(KIND=JPIM) :: MPL_CART_RANK INTEGER(KIND=JPIM) :: IDIMS(2), IPROC, IERR IDIMS(1)=KPROCW-1 IDIMS(2)=KPROCV-1 CALL MPI_CART_RANK(MPL_COMM_GRID, IDIMS, IPROC, IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_CART_RANK: mpi_cart_rank',KERROR=IERR) MPL_CART_RANK=IPROC+1 END FUNCTION MPL_CART_RANK ! ------------------------------------------------------------------ SUBROUTINE MPL_CART_COORDS(KPROC, KPROCW, KPROCV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_CART_COORDS => MPI_CART_COORDS8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KPROC INTEGER(KIND=JPIM), INTENT(OUT) :: KPROCW, KPROCV INTEGER(KIND=JPIM) :: IDIMS(2), IPROC, IERR IPROC=KPROC-1 CALL MPI_CART_COORDS(MPL_COMM_GRID, IPROC, 2, IDIMS, IERR) IF (IERR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_CART_COORDS: mpi_cart_coords',KERROR=IERR) KPROCW=IDIMS(1)+1 KPROCV=IDIMS(2)+1 END SUBROUTINE MPL_CART_COORDS ! ------------------------------------------------------------------ END MODULE MPL_GROUPS fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_mpif.F900000664000175000017500000000073115157200431022574 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MPIF #include "mpif.h" END MODULE MPL_MPIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_tour_table_mod.F900000664000175000017500000000312615157200431024641 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_TOUR_TABLE_MOD USE EC_PARKIND ,ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_RANK, MPL_ERRUNIT USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_TOUR_TABLE CONTAINS SUBROUTINE MPL_TOUR_TABLE(KOPPONENT, KEVEN) INTEGER(KIND=JPIM),INTENT(OUT)::KOPPONENT(:) INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL::KEVEN INTEGER(KIND=JPIM) :: ICIRCULAR(MPL_NUMPROC+1) INTEGER(KIND=JPIM) :: IEVEN,IMYPOS,ITMP,JK,JI LOGICAL :: LLABORT=.TRUE. IEVEN = ((MPL_NUMPROC+1)/2)*2 IF(SIZE(KOPPONENT) < IEVEN) THEN WRITE(MPL_ERRUNIT,*)'MPL_TOUR_TABLE: ERROR KOPPONENT dimension=',& & SIZE(KOPPONENT),'. MUST BE AT LEAST=',IEVEN CALL MPL_MESSAGE(CDMESSAGE='MPL_TOUR_TABLE: ERROR KOPPONENT dimension wrong',& & LDABORT=LLABORT) ENDIF DO JK = 1,IEVEN ICIRCULAR(JK) = JK ENDDO KOPPONENT(:) = -1 IMYPOS = MPL_RANK DO JK=1,IEVEN-1 KOPPONENT(JK) = ICIRCULAR(IEVEN-IMYPOS+1) ITMP = ICIRCULAR(IEVEN-1) DO JI=IEVEN-2,1,-1 ICIRCULAR(JI+1) = ICIRCULAR(JI) ENDDO ICIRCULAR(1) = ITMP IF(MPL_RANK < IEVEN) IMYPOS = MOD(IMYPOS,IEVEN-1)+1 ENDDO KOPPONENT(IEVEN) = MPL_RANK IF (PRESENT(KEVEN)) KEVEN = IEVEN END SUBROUTINE MPL_TOUR_TABLE END MODULE MPL_TOUR_TABLE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_init_mod.F900000664000175000017500000003037515157200431023452 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_INIT_MOD !**** MPL_INIT - Initialises the Message passing environment ! Purpose. ! -------- ! Must be called before any other MPL routine. !** Interface. ! ---------- ! CALL MPL_INIT ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! KOUTPUT - Level of printing for MPL routines ! =0: none ! =1: intermediate (default) ! =2: full trace ! KUNIT - Fortran Unit to receive printed trace ! LDINFO - = .TRUE. : Print informative msgs from MPL_INIT (default) ! = .FALSE. : Do not print ! LDENV - = .TRUE. : Propagate environment variables across participating tasks (default) ! = .FALSE. : Do not propagate ! ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_INIT aborts when an error is detected. ! KPROCS - Number of processes which have been initialised ! in the MPI_COMM_WORLD communicator ! ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! R. El Khatib 14-May-2007 Do not propagate environment if NECSX ! S. Saarinen 04-Oct-2009 Reduced output & redefined MPL_COMM_OML(1) ! P. Marguinaud 01-Jan-2011 Add LDENV argument ! R. El Khatib 24-May-2011 Make MPI2 the default expectation. ! P. Towers 3-Jul-2014 Add call to ec_cray_meminfo ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_INIT, OML_GET_MAX_THREADS USE MPL_MPI, ONLY : MPI_COMM, MPI_THREAD_SINGLE, MPI_THREAD_MULTIPLE, MPI_COMM_WORLD, & & MPI_BYTE, MPI_INTEGER USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_NUMPROC, MPL_NODE, MPL_NNODES, MPL_TASK_PER_NODE, & & MPL_NUMPROC,MPL_MAX_TASK_PER_NODE, MPL_NODE_TASKS, MPL_OUTPUT, MPL_RANK, & & MPL_OPPONENT, MPL_MYNODE, MPL_UNIT, LFULLNODES, MPL_NCPU_PER_NODE, & & LTHSAFEMPI, LINITMPI_VIA_MPL, LMPLUSERCOMM, LUSEHLMPI, MPLUSERCOMM, MPL_COMM, & & MPL_MBX_SIZE, MPL_WORLD_RANK, MPL_WORLD_SIZE, MPL_METHOD, MPL_IDS, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_BUFFER_METHOD_MOD, ONLY : MPL_BUFFER_METHOD USE MPL_TOUR_TABLE_MOD, ONLY : MPL_TOUR_TABLE USE MPL_LOCOMM_CREATE_MOD, ONLY : MPL_LOCOMM_CREATE USE MPL_ARG_MOD, ONLY : MPL_IARGC USE EC_ENV_MOD, ONLY : EC_PUTENV, EC_NUMENV, EC_ENVIRON IMPLICIT NONE PUBLIC MPL_INIT PRIVATE CONTAINS SUBROUTINE MPL_INIT(KOUTPUT,KUNIT,KERROR,KPROCS,LDINFO,LDENV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_INITIALIZED => MPI_INITIALIZED8, MPI_INIT => MPI_INIT8, & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_COMM_RANK => MPI_COMM_RANK8, & MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KOUTPUT,KUNIT INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KPROCS LOGICAL,INTENT(IN),OPTIONAL :: LDINFO,LDENV INTEGER(KIND=JPIM) :: IERROR,IP,ICOMM,IRANK,JNODE,JROC,ISTA INTEGER(KIND=JPIM) :: IMAX_THREADS, IRET, IROOT, INUM(2), ICOUNT INTEGER(KIND=JPIM) :: IREQUIRED,IPROVIDED INTEGER(KIND=JPIM) :: IWORLD_RANK, IWORLD_SIZE INTEGER(KIND=JPIM) :: IME LOGICAL :: LLABORT=.TRUE., LLINFO LOGICAL :: LLINIT LOGICAL :: LLENV CHARACTER(LEN=12) :: CL_MBX_SIZE CHARACTER(LEN=12) :: CL_ARCH CHARACTER(LEN=12) :: CL_TASKSPERNODE CHARACTER(LEN=1024):: CLENV CHARACTER(LEN=20) :: CL_METHOD,CL_HOST CHARACTER(LEN=1) :: CL_SET TYPE(MPI_COMM) :: MPL_COMM_INTERNAL IF(PRESENT(KOUTPUT)) THEN MPL_OUTPUT=MAX(0,KOUTPUT) ELSE MPL_OUTPUT=1 ENDIF IF(PRESENT(KUNIT)) THEN MPL_UNIT=MAX(0,KUNIT) ELSE MPL_UNIT=6 ENDIF IF(PRESENT(LDINFO)) THEN LLINFO = LDINFO ELSE LLINFO = .TRUE. ENDIF IF(PRESENT(LDENV)) THEN LLENV = LDENV ELSE LLENV = .TRUE. ENDIF IF(MPL_NUMPROC /= -1) THEN !! We do not want this extra message !! CALL MPL_MESSAGE(CDMESSAGE=' MPL_INIT CALLED MULTIPLE TIMES ') IF(PRESENT(KERROR)) THEN KERROR=0 ENDIF IF(PRESENT(KPROCS)) THEN KPROCS=MPL_NUMPROC ENDIF RETURN ENDIF CALL MPI_INITIALIZED(LLINIT, IRET) IF (.NOT.LLINIT) THEN CALL GET_ENVIRONMENT_VARIABLE('ARCH',CL_ARCH) #ifndef MPI1 IREQUIRED = MPI_THREAD_MULTIPLE IPROVIDED = MPI_THREAD_SINGLE CALL MPI_INIT_THREAD(IREQUIRED,IPROVIDED,IERROR) IF (IERROR /= 0) CALL ABOR1 ('MPL_INIT: MPI_INIT_THREAD FAILED') LTHSAFEMPI = (IPROVIDED >= IREQUIRED) #else CALL MPI_INIT(IERROR) IF (IERROR /= 0) CALL ABOR1 ('MPL_INIT: MPI_INIT FAILED') LTHSAFEMPI = .FALSE. #endif CALL MPI_COMM_RANK(MPI_COMM_WORLD, IME, IERROR) ! Print out thread safety etc. messages -- must use MPI_Comm_rank since MPL not initialized just yet IF (IME == 0 .AND. LLINFO ) THEN WRITE(MPL_UNIT,'(4(A,I0),1(A,L1))') & & 'MPL_INIT : MPI_THREAD_MULTIPLE=',MPI_THREAD_MULTIPLE,' , MPI_THREAD_SINGLE=',MPI_THREAD_SINGLE,& & ' , IREQUIRED=',IREQUIRED,' , IPROVIDED=',IPROVIDED,' , LTHSAFEMPI=',LTHSAFEMPI ENDIF LINITMPI_VIA_MPL = .TRUE. ! CALL ec_mpi_atexit() ! ifsaux/support/endian.c: to make sure MPI_FINALIZE gets called ELSE IERROR = 0 ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0) THEN CALL MPL_MESSAGE(CDMESSAGE=' MPL_INIT ERROR ',KERROR=IERROR,LDABORT=LLABORT) ENDIF ENDIF ! If LMPLUSERCOMM is not set use MPI_COMM_WORLD !mps: Sami Saarinen, 29-Nov-2016 ! Must be set *AFTER* MPI_INIT*() has ben called (or LLINIT is true) ! Otherwise MPI_COMM_WORLD not defined (at least not in OpenMPI) IF(LMPLUSERCOMM) THEN MPL_COMM = MPLUSERCOMM ELSE MPL_COMM = MPI_COMM_WORLD%MPI_VAL ENDIF MPL_COMM_INTERNAL%MPI_VAL = MPL_COMM CALL MPI_COMM_SIZE(MPL_COMM_INTERNAL,MPL_NUMPROC,IERROR) IF(PRESENT(KPROCS)) THEN KPROCS=MPL_NUMPROC ENDIF ALLOCATE (MPL_IDS(MPL_NUMPROC)) DO IP=1,MPL_NUMPROC MPL_IDS(IP)=IP ENDDO CALL MPI_COMM_RANK(MPL_COMM_INTERNAL, IRANK, IERROR) MPL_RANK=IRANK+1 IF (MPL_RANK == 1) THEN ! Clean up possible lockfile which gets created within MPL_ABORT CALL TABORT_DELETE_LOCKFILE() ENDIF LLINFO = LLINFO .AND. (MPL_RANK <= 1) IF (LLINFO) THEN IF(LMPLUSERCOMM) THEN WRITE(MPL_UNIT,'(2(A,I0))')'MPL_INIT : MPL_COMM=',MPL_COMM, ' (non-default) , MPL_NUMPROC=',MPL_NUMPROC ELSE WRITE(MPL_UNIT,'(2(A,I0))')'MPL_INIT : MPL_COMM=',MPL_COMM, ' (default) , MPL_NUMPROC=',MPL_NUMPROC ENDIF ENDIF !-- Propagate environment variables & argument lists ! Here we have to be careful and use MPI_BCAST directly (not MPL_BROADCAST) since ! 1) MPL_BUFFER_METHOD has not been called ! 2) MPL_COMM_OML has not been initialized since it is possible that only the ! master proc knows the # of threads (i.e. OMP_NUM_THREADS may be set only for master) ! Do not propagate on nec machine because the environment variables could be mpi-task-specific. IF (MPL_NUMPROC > 1 .AND. LLENV) THEN IROOT = 0 !-- Progate environment variables INUM(1) = 0 ! The number of environment variables INUM(2) = 0 ! Do not (=0) or do (=1) overwrite if particular environment variable already exists (0 = default) IF (MPL_RANK == 1) THEN ! Master proc inquires INUM(1) = EC_NUMENV() CALL GET_ENVIRONMENT_VARIABLE("EC_OVERWRITE_ENV",CLENV) IF( CLENV == '1' ) INUM(2) = 1 ENDIF ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(INUM,2,MPI_INTEGER,IROOT,MPL_COMM_INTERNAL,IERROR) ICOUNT = LEN(CLENV) DO IP=1,INUM(1) IF (MPL_RANK == 1) CALL EC_ENVIRON(IP,CLENV) ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(CLENV,ICOUNT,MPI_BYTE,IROOT,MPL_COMM_INTERNAL,IERROR) IF (MPL_RANK > 1) THEN IF (INUM(2) == 1) THEN CALL EC_PUTENV(CLENV,OVERWRITE=.TRUE.) ! ../support/env.c ; Unconditionally overwrite, even if already exists ELSE CALL EC_PUTENV(CLENV,OVERWRITE=.FALSE.) ! ../support/env.c ; Do not overwrite, if exists ENDIF ENDIF ENDDO !-- Propagate argument list (all under the bonnet using MPL_ARG_MOD-module) INUM = MPL_IARGC() ENDIF CALL OML_INIT() IMAX_THREADS = OML_GET_MAX_THREADS() ALLOCATE(MPL_COMM_OML(IMAX_THREADS)) IF (LMPLUSERCOMM) THEN MPL_COMM_OML(1) = MPLUSERCOMM ISTA = 2 ELSE ISTA = 1 ENDIF IF (MPL_NUMPROC > 1) THEN DO IP=ISTA,IMAX_THREADS CALL MPL_LOCOMM_CREATE(MPL_NUMPROC,MPL_COMM_OML(IP)) ENDDO MPL_COMM = MPL_COMM_OML(1) ! i.e. not necessary MPI_COMM_WORLD anymore MPL_COMM_INTERNAL%MPI_VAL = MPL_COMM ELSE MPL_COMM_OML(ISTA:IMAX_THREADS)=MPL_COMM ENDIF CL_METHOD=' ' CALL GET_ENVIRONMENT_VARIABLE('MPL_METHOD',CL_METHOD) IF (CL_METHOD == 'JP_BLOCKING_STANDARD' ) THEN MPL_METHOD=JP_BLOCKING_STANDARD ELSE MPL_METHOD=JP_BLOCKING_BUFFERED ENDIF MPL_MBX_SIZE=1000000 CL_MBX_SIZE=' ' CALL GET_ENVIRONMENT_VARIABLE('MPL_MBX_SIZE',CL_MBX_SIZE) IF (CL_MBX_SIZE /= ' ') THEN READ(CL_MBX_SIZE,*) MPL_MBX_SIZE ENDIF IF (CL_METHOD == 'JP_BLOCKING_STANDARD' ) THEN IF (LLINFO) WRITE(MPL_UNIT,'(A,I0)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_STANDARD , MPL_MBX_SIZE=',MPL_MBX_SIZE ELSE IF (LLINFO) WRITE(MPL_UNIT,'(A,I0)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED , MPL_MBX_SIZE=',MPL_MBX_SIZE ENDIF CALL MPL_BUFFER_METHOD(KMP_TYPE=MPL_METHOD,KMBX_SIZE=MPL_MBX_SIZE,LDINFO=.FALSE.) LUSEHLMPI = .TRUE. CALL MPI_COMM_RANK (MPI_COMM_WORLD, IWORLD_RANK, IERROR) CALL MPI_COMM_SIZE (MPI_COMM_WORLD, IWORLD_SIZE, IERROR) #ifdef LINUX CALL LINUX_BIND (IWORLD_RANK, IWORLD_SIZE) #endif !-- World-wide tasks MPL_WORLD_RANK = IWORLD_RANK MPL_WORLD_SIZE = IWORLD_SIZE !!!! If you are not at ECMWF this may need changing!!!! CALL GET_ENVIRONMENT_VARIABLE('EC_TASKS_PER_NODE',CL_TASKSPERNODE) IF (CL_TASKSPERNODE(1:1) == ' ' ) THEN CALL GET_ENVIRONMENT_VARIABLE('HOST',CL_HOST) IF(CL_HOST(1:3) == 'cck') THEN ! KNL MPL_NCPU_PER_NODE=64 ELSEIF(CL_HOST(1:3) == 'cct') THEN ! Test-cluster MPL_NCPU_PER_NODE=24 ELSEIF(CL_HOST(1:2) == 'cc') THEN ! cca/ccb MPL_NCPU_PER_NODE=36 ELSEIF(CL_HOST(1:3) == 'lxg') THEN ! GPU-cluster MPL_NCPU_PER_NODE=24 ELSEIF (CL_HOST(1:2) == 'c1') THEN MPL_NCPU_PER_NODE=64 ELSEIF(CL_HOST(1:3) == 'hpc') THEN MPL_NCPU_PER_NODE=32 ELSE MPL_NCPU_PER_NODE=1 !IF(LLINFO) WRITE(MPL_UNIT,'(A)')'MPL_INIT : MPL_NCPU_PER_NODE = 1 (CAUTION: could not be inferred from hostname!)' ENDIF ELSE READ(CL_TASKSPERNODE,*) MPL_NCPU_PER_NODE ENDIF MPL_MAX_TASK_PER_NODE=MAX(1, MPL_NCPU_PER_NODE/IMAX_THREADS) LFULLNODES=MOD(MPL_NUMPROC,MPL_MAX_TASK_PER_NODE) == 0 MPL_NNODES=(MPL_NUMPROC-1)/MPL_MAX_TASK_PER_NODE+1 ALLOCATE(MPL_TASK_PER_NODE(MPL_NNODES)) ALLOCATE(MPL_NODE(MPL_NUMPROC)) ALLOCATE(MPL_NODE_TASKS(MPL_NNODES,MPL_MAX_TASK_PER_NODE)) MPL_NODE_TASKS(:,:)=-99 ICOUNT=0 DO JNODE=1,MPL_NNODES DO JROC=1,MPL_MAX_TASK_PER_NODE ICOUNT=ICOUNT+1 IF (ICOUNT<=MPL_NUMPROC) THEN MPL_NODE(ICOUNT)=JNODE MPL_TASK_PER_NODE(JNODE) = JROC MPL_NODE_TASKS(JNODE,JROC) = ICOUNT ENDIF ENDDO ENDDO MPL_MYNODE=(MPL_RANK-1)/MPL_MAX_TASK_PER_NODE+1 !WRITE(MPL_UNIT,*) 'MPL_INIT : NCPU_PER_NODE,MPL_MAX_TASK_PER_NODE,MPL_NNODES,MPL_MYNODE ',& ! & MPL_NCPU_PER_NODE,MPL_MAX_TASK_PER_NODE,MPL_NNODES,MPL_MYNODE !WRITE(MPL_UNIT,*) 'MPL_INIT : MPL_NODE_TASKS(MPL_MYNODE,1:MPL_TASK_PER_NODE(MPL_MYNODE)) ', & ! & MPL_NODE_TASKS(MPL_MYNODE,1:MPL_TASK_PER_NODE(MPL_MYNODE)) ALLOCATE(MPL_OPPONENT(MPL_NUMPROC+1)) CALL MPL_TOUR_TABLE(MPL_OPPONENT) RETURN END SUBROUTINE MPL_INIT END MODULE MPL_INIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_open_mod.F900000664000175000017500000000701415157200431023442 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_OPEN_MOD ! ! Purpose. open an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_open(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! ktype - 1 = open for reading , 2 = writing ! kname - Name of the file ! output arguments: ! kfptr - handle for file pointer ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_OPEN) ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND ,ONLY : JPIM USE MPL_MPI, ONLY : MPI_FILE, MPI_INFO, MPI_COMM, MPI_MODE_WRONLY, MPI_MODE_RDONLY, MPI_MODE_CREATE, MPI_INFO_NULL USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO, MPL_COMM_IO IMPLICIT NONE PRIVATE PUBLIC MPL_OPEN CONTAINS SUBROUTINE MPL_OPEN(KFPTR,KTYPE,KNAME,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_OPEN => MPI_FILE_OPEN8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE INTEGER(KIND=JPIM),INTENT(OUT) :: KFPTR,KERROR TYPE(MPI_FILE) :: KFPTR_LOCAL CHARACTER(LEN=*) :: KNAME INTEGER(KIND=JPIM) :: MODE TYPE(MPI_INFO) :: INFO TYPE(MPI_COMM) :: MPL_COMM_IO_LOCAL #ifndef MPI1 ! ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- ! IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KTYPE == 1 ) THEN MODE = MPI_MODE_RDONLY ELSEIF( KTYPE == 2 ) THEN MODE = MPI_MODE_WRONLY + MPI_MODE_CREATE ELSE KERROR = -1 RETURN ENDIF INFO = MPI_INFO_NULL ! ----------------------------------------------------------------- ! ! 2. open the file ! ---------------------- MPL_COMM_IO_LOCAL%MPI_VAL=MPL_COMM_IO CALL MPI_FILE_OPEN(MPL_COMM_IO_LOCAL,KNAME,MODE,INFO,KFPTR_LOCAL,KERROR) KFPTR=KFPTR_LOCAL%MPI_VAL ! ! ! ----------------------------------------------------------------- #else CALL ABOR1('MPL_OPEN not built with MPI2') #endif RETURN END SUBROUTINE MPL_OPEN END MODULE MPL_OPEN_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_write_mod.F900000664000175000017500000002047715157200431023643 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_WRITE_MOD ! ! Purpose. write to an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_write(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kfptr - handle for file ! kop - requested operation ! kbuf - buffer containing data to be written ! klen - length of buffer in words ! input/output arguements: ! kreq - request handle for non-blocking operations ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_WRITE) ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND ,ONLY : JPIM ,JPRM USE MPL_MPI, ONLY : MPI_REQUEST, MPI_STATUS, MPI_FILE, MPI_INTEGER, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO, MPL_IOP IMPLICIT NONE INTERFACE MPL_WRITE MODULE PROCEDURE MPL_WRITE_INT,MPL_WRITE_REAL8 END INTERFACE PRIVATE PUBLIC MPL_WRITE CONTAINS SUBROUTINE MPL_WRITE_INT(KFPTR,KOP,KBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_WRITE_SHARED => MPI_FILE_WRITE_SHARED8, & MPI_FILE_WRITE_ORDERED => MPI_FILE_WRITE_ORDERED8, & MPI_FILE_IWRITE_SHARED => MPI_FILE_IWRITE_SHARED8, & MPI_FILE_WRITE_ORDERED_BEGIN => MPI_FILE_WRITE_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, & MPI_FILE_WRITE_ORDERED_END => MPI_FILE_WRITE_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR TYPE(MPI_FILE) :: KFPTR_LOCAL INTEGER(KIND=JPIM) :: KBUF(:) TYPE(MPI_REQUEST) :: KREQ TYPE(MPI_STATUS) :: STATUS KFPTR_LOCAL%MPI_VAL=KFPTR ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking write, non collective, shared file pointer CALL MPI_FILE_WRITE_SHARED(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking write, non collective, shared file pointer CALL MPI_FILE_IWRITE_SHARED(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED_BEGIN(KFPTR_LOCAL,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_WRITE_ORDERED_END(KFPTR_LOCAL,& & KBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF #else CALL ABOR1('MPL_WRITE_INT not built with MPI2') #endif ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_WRITE_INT SUBROUTINE MPL_WRITE_REAL8(KFPTR,KOP,PBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_WRITE_SHARED => MPI_FILE_WRITE_SHARED8, & MPI_FILE_WRITE_ORDERED => MPI_FILE_WRITE_ORDERED8, & MPI_FILE_IWRITE_SHARED => MPI_FILE_IWRITE_SHARED8, & MPI_FILE_WRITE_ORDERED_BEGIN => MPI_FILE_WRITE_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, & MPI_FILE_WRITE_ORDERED_END => MPI_FILE_WRITE_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR REAL(KIND=JPRM) :: PBUF(:) TYPE(MPI_REQUEST) :: KREQ TYPE(MPI_FILE) :: KFPTR_LOCAL TYPE(MPI_STATUS) :: STATUS KFPTR_LOCAL%MPI_VAL=KFPTR ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking write, non collective, shared file pointer CALL MPI_FILE_WRITE_SHARED(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking write, non collective, shared file pointer CALL MPI_FILE_IWRITE_SHARED(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED_BEGIN(KFPTR_LOCAL,& & PBUF,& & KLEN,& & MPI_REAL8,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_WRITE_ORDERED_END(KFPTR_LOCAL,& & PBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF #else CALL ABOR1('MPL_WRITE_REAL8 not built with MPI2') #endif ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_WRITE_REAL8 END MODULE MPL_WRITE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_testsome_mod.F900000664000175000017500000000547715157200431024357 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_TESTSOME_MOD USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_REQUEST, MPI_STATUS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE ! P. Marguinaud : 01-Jan-2011 ! KARRAY_OF_REQUESTS (see MPI_TESTSOME) ! KARRAY_OF_INDICES (see MPI_TESTSOME) ! KARRAY_OF_INDICES1 pending requests ! KOUTCOUNT1 number of pending requests PRIVATE PUBLIC :: MPL_TESTSOME CONTAINS SUBROUTINE MPL_TESTSOME (KARRAY_OF_REQUESTS, KARRAY_OF_INDICES, & & KARRAY_OF_INDICES1, KOUTCOUNT, KOUTCOUNT1, & & KERROR, CDSTRING, LDWAIT) INTEGER(KIND=JPIM), INTENT (IN) :: KARRAY_OF_REQUESTS (:) INTEGER(KIND=JPIM), INTENT (OUT) :: KARRAY_OF_INDICES (:) INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KARRAY_OF_INDICES1 (:) INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KOUTCOUNT INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KOUTCOUNT1 INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KERROR CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING LOGICAL, INTENT(IN), OPTIONAL :: LDWAIT TYPE(MPI_REQUEST) :: KARRAY_OF_REQUESTS_LOCAL(SIZE(KARRAY_OF_REQUESTS)) INTEGER(KIND=JPIM) :: IERROR INTEGER(KIND=JPIM) :: IINCOUNT INTEGER(KIND=JPIM) :: IOUTCOUNT TYPE(MPI_STATUS) :: IARRAY_OF_STATUSES(SIZE(KARRAY_OF_REQUESTS)) INTEGER(KIND=JPIM) :: II, IJ, IK LOGICAL :: LLWAIT LOGICAL :: LLABORT=.TRUE. IINCOUNT = SIZE (KARRAY_OF_REQUESTS) KARRAY_OF_INDICES = -1 KARRAY_OF_REQUESTS_LOCAL(:)%MPI_VAL=KARRAY_OF_REQUESTS(:) LLWAIT = .FALSE. IF (PRESENT (LDWAIT)) LLWAIT = LDWAIT IF (LLWAIT) THEN CALL MPI_WAITSOME(IINCOUNT, KARRAY_OF_REQUESTS_LOCAL, IOUTCOUNT, & KARRAY_OF_INDICES, IARRAY_OF_STATUSES, IERROR) ELSE CALL MPI_TESTSOME(IINCOUNT, KARRAY_OF_REQUESTS_LOCAL, IOUTCOUNT, & KARRAY_OF_INDICES, IARRAY_OF_STATUSES, IERROR) ENDIF IF (PRESENT (KOUTCOUNT)) THEN KOUTCOUNT = IOUTCOUNT ENDIF IF (PRESENT (KOUTCOUNT1)) THEN KOUTCOUNT1 = IINCOUNT - IOUTCOUNT ENDIF IF (PRESENT (KARRAY_OF_INDICES1)) THEN KARRAY_OF_INDICES1 = -1 IJ = 1 IK = 1 DO II = 1, IINCOUNT IF (II .EQ. KARRAY_OF_INDICES (IJ)) THEN IJ = IJ + 1 ELSE KARRAY_OF_INDICES1 (IK) = II IK = IK + 1 ENDIF ENDDO ENDIF IF (PRESENT (KERROR)) THEN KERROR = IERROR ELSE IF(IERROR /= 0) CALL MPL_MESSAGE(CDMESSAGE='MPL_TESTSOME',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_TESTSOME END MODULE MPL_TESTSOME_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_setdflt_comm_mod.F900000664000175000017500000000420015157200431025153 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_SETDFLT_COMM_MOD !**** MPL_SETDFLT_COMM Set new default communicator ! Purpose. ! -------- ! Set new communicator as default, and return old communicator !** Interface. ! ---------- ! CALL MPL_SETDFLT_COMM(KCOMM,KCOMM_OLD) ! Input required arguments : ! ------------------------- ! KCOMM - New communicator ! Input optional arguments : ! ------------------------- ! Output required arguments : ! ------------------------- ! KCOMM_OLD - Old communicator ! Output optional arguments : ! ------------------------- ! Author. ! ------- ! J.Hague ! Modifications. ! -------------- ! Original: 2003-16-07 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_COMM_SIZE USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_RANK, MPL_NUMPROC IMPLICIT NONE PRIVATE PUBLIC MPL_SETDFLT_COMM CONTAINS SUBROUTINE MPL_SETDFLT_COMM(KCOMM,KCOMM_OLD) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT) :: KCOMM_OLD TYPE(MPI_COMM) :: KCOMM_LOCAL INTEGER(KIND=JPIM) :: IER INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM) :: IRANK ITID = OML_MY_THREAD() KCOMM_LOCAL%MPI_VAL=KCOMM KCOMM_OLD=MPL_COMM_OML(ITID) MPL_COMM_OML(ITID)=KCOMM ! Get rank in and size of new communicator CALL MPI_COMM_RANK(KCOMM_LOCAL, IRANK, IER) MPL_RANK = IRANK + 1 CALL MPI_COMM_SIZE(KCOMM_LOCAL, MPL_NUMPROC, IER) RETURN END SUBROUTINE MPL_SETDFLT_COMM END MODULE MPL_SETDFLT_COMM_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_data_module.F900000664000175000017500000000651215157200431024122 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_DATA_MODULE ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ ! variables controlling the execution of MPL ! MPL_METHOD : buffering type ! MPL_MBX_SIZE : size of application mailbox, (bytes) ! used when MPL_METHOD=JP_BLOCKING_BUFFERED ! MPL_COMM : default communicator in use ! MPL_COMM_OML : communicators for messages between corresponding OML-threads ! MPL_UNIT : Fortran I/O unit for messages (default=6) ! MPL_ERRUNIT : Fortran I/O unit for error messages (default=0) ! MPL_OUTPUT : controls contents of Output (see mpl_init_mod.F90 for values/default) ! MPL_RANK : rank of the process within MPL_COMM_OML(1) ! MPL_NUMPROC : number of processes in MPL_COMM_OML(1) ! MPL_IDS : array of processor numbers ! LUSEHLMPI : always use high level MPI calls (collective comm.) ! LINITMPI_VIA_MPL : true if MPI has been initialized from within MPL_INIT() ! LTHSAFEMPI : Thread safe MPI, if .TRUE. (default) USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE PRIVATE :: JPIM SAVE PUBLIC INTEGER(KIND=JPIM) :: MPL_METHOD, MPL_MBX_SIZE, MPL_UNIT=6, MPL_OUTPUT=1 INTEGER(KIND=JPIM) :: MPL_RANK=0,MPL_NUMPROC = -1,MPL_ERRUNIT=0 INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_IDS(:) INTEGER(KIND=JPIM) :: MPL_COMM INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_COMM_OML(:) INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_OPPONENT(:) INTEGER(KIND=JPIM) :: MPL_NCPU_PER_NODE=1 INTEGER(KIND=JPIM) :: MPL_MAX_TASK_PER_NODE INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_TASK_PER_NODE(:) INTEGER(KIND=JPIM) :: MPL_NNODES LOGICAL :: LFULLNODES INTEGER(KIND=JPIM) :: MPL_MYNODE=0 INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_NODE(:) INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_NODE_TASKS(:,:) !INTEGER_M,ALLOCATABLE :: MPL_ATTACHED_BUFFER(:) ! needs to ge a TARGET for coexistence with MPE INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: MPL_ATTACHED_BUFFER(:) LOGICAL :: LUSEHLMPI LOGICAL :: LINITMPI_VIA_MPL = .FALSE. LOGICAL :: LTHSAFEMPI = .TRUE. INTEGER(KIND=JPIM),PARAMETER :: JP_ATTACHED_BUFFER_BYTES = JPIM INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_STANDARD = 1 INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_BUFFERED = 2 INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_SYNCHRONOUS = 3 INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_READY = 4 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_STANDARD = 5 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_BUFFERED = 6 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_SYNCHRONOUS = 7 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_READY = 8 LOGICAL :: LMPLUSERCOMM = .FALSE. INTEGER(KIND=JPIM) :: MPLUSERCOMM = -1 INTEGER(KIND=JPIM) :: MPL_SEND_COUNT, MPL_SEND_BYTES INTEGER(KIND=JPIM) :: MPL_RECV_COUNT, MPL_RECV_BYTES INTEGER(KIND=JPIM) :: MPL_WORLD_RANK = -1 INTEGER(KIND=JPIM) :: MPL_WORLD_SIZE = 0 END MODULE MPL_DATA_MODULE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpi4to8.F900000664000175000017500000000074215157200431022277 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI4TO8 USE MPI4TO8_S USE MPI4TO8_M END MODULE MPI4TO8 fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_end_mod.F900000664000175000017500000000753015157200431023252 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_END_MOD !**** MPL_END - Terminates the message passing environment ! Purpose. ! -------- ! Cleans up all of the MPI state. ! Subsequently, no MPI routine can be called !** Interface. ! ---------- ! CALL MPL_END ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! LDMEMINFO - print memory info (default True) ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_END aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P. Towers 3-Jul-2014 Add call to ec_cray_meminfo ! ------------------------------------------------------------------ USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_PTR USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, LINITMPI_VIA_MPL, MPL_ATTACHED_BUFFER, JP_ATTACHED_BUFFER_BYTES USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PUBLIC MPL_END PRIVATE INTEGER :: IERROR CONTAINS SUBROUTINE MPL_END(KERROR,LDMEMINFO) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_BUFFER_DETACH => MPI_BUFFER_DETACH8, MPI_FINALIZE => MPI_FINALIZE8 #endif INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR LOGICAL ,INTENT(IN), OPTIONAL :: LDMEMINFO INTEGER(KIND=JPIM) :: IBUFFMPI,IERROR LOGICAL :: LLMEMINFO LOGICAL,PARAMETER :: LLABORT=.TRUE. TYPE(C_PTR) :: MPL_ATTACHED_BUFFER_ADDRESS #include "ec_mpi_finalize.intfb.h" IF(MPL_NUMPROC < 1) THEN IF(MPL_NUMPROC == -1) THEN IF (.NOT.LINITMPI_VIA_MPL) THEN ! Neither MPL_INIT_MOD nor MPL_ARG_MOD -modules were called before this CALL MPL_MESSAGE(CDMESSAGE=' MPL_END CALLED BEFORE MPL_INIT ') ENDIF !!-- we do not want the following message to appear, since its non-fatal !! ELSEIF(MPL_NUMPROC == -2) THEN !! CALL MPL_MESSAGE(CDMESSAGE=' MPL_END CALLED MULTIPLE TIMES ') ENDIF IF(PRESENT(KERROR)) THEN IERROR=0 KERROR=IERROR ENDIF RETURN ENDIF IF (ALLOCATED(MPL_ATTACHED_BUFFER)) THEN IF( MPI_IS_FINALIZED() ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_END -- Cannot call MPI_Buffer_detach() as MPI is already finalized',LDABORT=.FALSE.) ELSE IBUFFMPI=SIZE(MPL_ATTACHED_BUFFER) * JP_ATTACHED_BUFFER_BYTES ! in bytes CALL MPI_BUFFER_DETACH(MPL_ATTACHED_BUFFER_ADDRESS,IBUFFMPI,IERROR) IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF( IERROR /= 0 )THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_END ',KERROR=IERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF DEALLOCATE(MPL_ATTACHED_BUFFER) ENDIF LLMEMINFO=.TRUE. IF(PRESENT(LDMEMINFO)) LLMEMINFO=LDMEMINFO CALL EC_MPI_FINALIZE(IERROR,LINITMPI_VIA_MPL,LLMEMINFO,"mpl_end") MPL_NUMPROC = -2 LINITMPI_VIA_MPL = .FALSE. IF(PRESENT(KERROR)) THEN KERROR=IERROR ENDIF RETURN END SUBROUTINE MPL_END FUNCTION MPI_IS_FINALIZED() LOGICAL :: MPI_IS_FINALIZED LOGICAL :: LLINIT, LLFIN INTEGER(KIND=JPIM) :: IERR MPI_IS_FINALIZED = .FALSE. CALL MPI_INITIALIZED(LLINIT,IERR) IF (LLINIT .AND. IERR == 0) THEN CALL MPI_FINALIZED(LLFIN,IERR) IF( IERR == 0 ) THEN MPI_IS_FINALIZED = LLFIN ENDIF ENDIF END FUNCTION END MODULE MPL_END_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_allreduce_mod.F900000664000175000017500000006274315157200431024453 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLREDUCE_MOD !**** MPL_ALLREDUCE Perform collective communication ! Purpose. ! -------- ! To calculate global MIN,MAX,SUM or IEOR and return result to all processes. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array or scalar !** Interface. ! ---------- ! CALL MPL_ALLREDUCE ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message to be collectively communicated ! (can be type REAL*4, REAL*8 or INTEGER) (also output) ! CDOPER - Global operation to be performed : 'MAX', 'MIN', 'SUM' or 'IEOR' ! Input optional arguments : ! ------------------------- ! LDREPROD - Reproducibility flag for SUMmation-operator. ! Meaningful only for REAL-numbers. ! Three modes (applicable for REAL-number only): ! 1) Not provided at all (the default) ==> MPL_ABORT ! 2) Provided and .TRUE. ==> Use home-written binary tree ! No MPI_ALLREDUCE used. ! 3) Provided, but .FALSE. ==> let MPI_ALLREDUCE do the summation. ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_ALLREDUCE aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud, S.Saarinen ECMWF ! Modifications. ! -------------- ! Original: 2001-02-02 ! F. Vana 05-Mar-2015 Support for single precision ! E. Arbogast 11-Jul-2022 Allocate ZRECVBUF in the heap to fix bug ! detected in VARBC_PRED:PRED_STATS ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPRM, JPIB USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_OP, MPI_REQUEST, MPI_MIN, MPI_MAX, MPI_SUM, MPI_BXOR, MPI_ALLREDUCE, & & MPI_INTEGER, MPI_INTEGER8, MPI_REAL4, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_OUTPUT, MPL_UNIT, MPL_RANK, MPL_NUMPROC, MPL_ERRUNIT, & & JP_NON_BLOCKING_STANDARD, JP_BLOCKING_STANDARD USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_SEND_MOD, ONLY : MPL_SEND USE MPL_RECV_MOD, ONLY : MPL_RECV USE MPL_WAIT_MOD, ONLY : MPL_WAIT USE MPL_BROADCAST_MOD, ONLY : MPL_BROADCAST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_ALLREDUCE MODULE PROCEDURE MPL_ALLREDUCE_REAL8, MPL_ALLREDUCE_REAL4, MPL_ALLREDUCE_INT, & MPL_ALLREDUCE_INT8, & MPL_ALLREDUCE_REAL8_SCALAR, MPL_ALLREDUCE_REAL4_SCALAR, & MPL_ALLREDUCE_INT_SCALAR, MPL_ALLREDUCE_INT8_SCALAR, & MPL_ALLREDUCE_REAL4_2D, MPL_ALLREDUCE_REAL8_2D END INTERFACE PUBLIC MPL_ALLREDUCE CONTAINS SUBROUTINE MPL_ALLREDUCE_INT_SCALAR(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) INTEGER(KIND=JPIM),INTENT(INOUT) :: KSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ISENDBUF(1) ISENDBUF(1) = KSENDBUF CALL MPL_ALLREDUCE(ISENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) KSENDBUF = ISENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_INT_SCALAR SUBROUTINE MPL_ALLREDUCE_INT8_SCALAR(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) INTEGER(KIND=JPIB),INTENT(INOUT) :: KSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIB) ISENDBUF(1) ISENDBUF(1) = KSENDBUF CALL MPL_ALLREDUCE(ISENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) KSENDBUF = ISENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_INT8_SCALAR SUBROUTINE MPL_ALLREDUCE_REAL8_SCALAR(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) REAL(KIND=JPRD),INTENT(INOUT) :: PSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRD) :: ZSENDBUF(1) ZSENDBUF(1) = PSENDBUF CALL MPL_ALLREDUCE(ZSENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) PSENDBUF = ZSENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_REAL8_SCALAR SUBROUTINE MPL_ALLREDUCE_REAL4_SCALAR(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) REAL(KIND=JPRM),INTENT(INOUT) :: PSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRM) ZSENDBUF(1) ZSENDBUF(1) = PSENDBUF CALL MPL_ALLREDUCE(ZSENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) PSENDBUF = ZSENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_REAL4_SCALAR SUBROUTINE MPL_ALLREDUCE_INT(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM), ALLOCATABLE :: IRECVBUF(:) INTEGER(KIND=JPIM) :: ISENDCOUNT,IERROR TYPE(MPI_COMM) :: ICOMM TYPE(MPI_OP) :: IOPER INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IERROR = 0 ALLOCATE(IRECVBUF(SIZE(KSENDBUF))) IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM ELSEIF(CDOPER(1:4) == 'IEOR' .OR. CDOPER(1:4) == 'ieor' ) THEN IOPER = MPI_BXOR ELSEIF(CDOPER(1:4) == 'XOR' .OR. CDOPER(1:4) == 'xor' ) THEN IOPER = MPI_BXOR ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(KSENDBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(KSENDBUF,IRECVBUF,ISENDCOUNT,MPI_INTEGER, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & KSENDBUF(:) = IRECVBUF(:) DEALLOCATE(IRECVBUF) END SUBROUTINE MPL_ALLREDUCE_INT SUBROUTINE MPL_ALLREDUCE_INT8(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) INTEGER(KIND=JPIB),INTENT(INOUT) :: KSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIB) :: IRECVBUF(SIZE(KSENDBUF)) INTEGER(KIND=JPIM) :: ISENDCOUNT,IERROR TYPE(MPI_COMM) :: ICOMM TYPE(MPI_OP) :: IOPER INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM ELSEIF(CDOPER(1:4) == 'IEOR' .OR. CDOPER(1:4) == 'ieor' ) THEN IOPER = MPI_BXOR ELSEIF(CDOPER(1:4) == 'XOR' .OR. CDOPER(1:4) == 'xor' ) THEN IOPER = MPI_BXOR ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(KSENDBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(KSENDBUF,IRECVBUF,ISENDCOUNT,MPI_INTEGER8, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_INTEGER8%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_INTEGER8%MPI_VAL) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & KSENDBUF(:) = IRECVBUF(:) END SUBROUTINE MPL_ALLREDUCE_INT8 SUBROUTINE MPL_ALLREDUCE_REAL8(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRD),INTENT(INOUT) :: PSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRD), ALLOCATABLE :: ZRECVBUF(:) INTEGER(KIND=JPIM) :: ITAG, ICOUNT LOGICAL :: LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,IERROR TYPE(MPI_COMM) :: ICOMM TYPE(MPI_OP) :: IOPER INTEGER(KIND=JPIM) :: IP2,II,IHALF,JSTAGE,ISEND,IRECV,IMSENT TYPE(MPI_REQUEST) :: ISREQ(MPL_NUMPROC) INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. ALLOCATE(ZRECVBUF(SIZE(PSENDBUF))) IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE( CDMESSAGE='MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF (LLREPRODSUM) THEN !-- Near reproducible summation (independent of number of threads) IP2=0 DO IP2=IP2+1 IF(2**IP2 >= MPL_NUMPROC) EXIT ENDDO IMSENT=0 DO JSTAGE=IP2,1,-1 ! WRITE(0,*) 'STAGE ',JSTAGE ITAG = 2001+JSTAGE II = 2**JSTAGE IHALF = II/2 ISEND = MPL_RANK - IHALF IF(ISEND > 0 .AND. MPL_RANK <= II) THEN IMSENT=IMSENT+1 CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM%MPI_VAL,KTAG=ITAG,KERROR=IERROR,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT)%MPI_VAL,CDSTRING='MPLS_SEND') ! write(0,*) 'I SEND TO ',MPL_RANK,ISEND ENDIF IRECV=MPL_RANK + IHALF IF(IRECV <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM%MPI_VAL,KTAG=ITAG,& &KERROR=IERROR,KOUNT=ICOUNT) ! write(0,*) 'I RECV FROM ',MPL_RANK,IRECV PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ENDIF ENDDO IF(IMSENT > 0) THEN CALL MPL_WAIT(ISREQ(1:IMSENT),CDSTRING='MPLS_SEND') ENDIF IF (MPL_RANK == 1) THEN ZRECVBUF(:) = PSENDBUF(:) ENDIF ! write(0,*) 'enter broadcast ' CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM%MPI_VAL,KROOT=1,KERROR=IERROR) ! write(0,*) 'exit broadcast ' !!$ IMSENT=0 !!$ DO JSTAGE=1,IP2 !!$ ITAG = 2001+JSTAGE !!$ WRITE(0,*) 'STAGE BACK ',JSTAGE !!$ II = 2**JSTAGE !!$ IHALF = II/2 !!$ ISEND=MPL_RANK + IHALF !!$ IF(ISEND <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN !!$ IMSENT=IMSENT+1 !!$ CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& !!$ &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT),CDSTRING='MPLS_SEND') !!$ WRITE(0,*) 'I SEND BACK TO ',MPL_RANK,ISEND !!$ ENDIF !!$ IRECV=MPL_RANK - IHALF !!$ IF(IRECV > 0 .AND. MPL_RANK <= II) THEN !!$ WRITE(0,*) 'I RECV BACK FROM ',MPL_RANK,IRECV !!$ CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM,KTAG=ITAG,& !!$ &KERROR=IERROR,KOUNT=ICOUNT) !!$ ENDIF !!$ ENDDO !!$ IF(IMSENT > 0) THEN !!$ CALL MPL_WAIT(KREQUEST=ISREQ(1:IMSENT),CDSTRING='MPLS_SEND') !!$ ENDIF ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,MPI_REAL8, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:) = ZRECVBUF(:) DEALLOCATE(ZRECVBUF) END SUBROUTINE MPL_ALLREDUCE_REAL8 SUBROUTINE MPL_ALLREDUCE_REAL8_2D(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRD),INTENT(INOUT) :: PSENDBUF(:,:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRD) :: ZRECVBUF(SIZE(PSENDBUF(:,1)),SIZE(PSENDBUF(1,:))) INTEGER(KIND=JPIM) ITAG, ICOUNT LOGICAL LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,IERROR TYPE(MPI_COMM) :: ICOMM TYPE(MPI_OP) :: IOPER INTEGER(KIND=JPIM) :: IP2,II,IHALF,JSTAGE,ISEND,IRECV,IMSENT INTEGER(KIND=JPIM) :: ISREQ(MPL_NUMPROC) INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) !#ifndef NAGFOR !IF (ISENDCOUNT > 0) THEN ! IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1)))-LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 8_JPIB*(ISENDCOUNT - 1) ) THEN ! CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ! ENDIF !ENDIF !#endif !IF (LLREPRODSUM) THEN !-- Near reproducible summation (independent of number of threads) ! IP2=0 ! DO ! IP2=IP2+1 ! IF(2**IP2 >= MPL_NUMPROC) EXIT ! ENDDO ! IMSENT=0 ! DO JSTAGE=IP2,1,-1 ! WRITE(0,*) 'STAGE ',JSTAGE ! ITAG = 2001+JSTAGE ! II = 2**JSTAGE ! IHALF = II/2 ! ISEND = MPL_RANK - IHALF ! IF(ISEND > 0 .AND. MPL_RANK <= II) THEN ! IMSENT=IMSENT+1 ! CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& ! &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT),CDSTRING='MPLS_SEND') ! write(0,*) 'I SEND TO ',MPL_RANK,ISEND ! ENDIF ! IRECV=MPL_RANK + IHALF ! IF(IRECV <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN ! CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM,KTAG=ITAG,& ! &KERROR=IERROR,KOUNT=ICOUNT) ! write(0,*) 'I RECV FROM ',MPL_RANK,IRECV ! PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ! ENDIF ! ENDDO ! IF(IMSENT > 0) THEN ! CALL MPL_WAIT(KREQUEST=ISREQ(1:IMSENT),CDSTRING='MPLS_SEND') ! ENDIF ! IF (MPL_RANK == 1) THEN ! ZRECVBUF(:) = PSENDBUF(:) ! ENDIF ! write(0,*) 'enter broadcast ' ! CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM,KROOT=1,KERROR=IERROR) ! write(0,*) 'exit broadcast ' !ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,MPI_REAL8, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_REAL8%MPI_VAL) ENDIF !ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',CDSTRING=CDSTRING, & & KERROR=IERROR,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:,:) = ZRECVBUF(:,:) END SUBROUTINE MPL_ALLREDUCE_REAL8_2D SUBROUTINE MPL_ALLREDUCE_REAL4(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRM),INTENT(INOUT) :: PSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRM), ALLOCATABLE :: ZRECVBUF(:) INTEGER(KIND=JPIM) :: IPROC, ITAG, ICOUNT LOGICAL :: LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,IERROR TYPE(MPI_COMM) :: ICOMM TYPE(MPI_OP) :: IOPER INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. ALLOCATE(ZRECVBUF(SIZE(PSENDBUF))) IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF (LLREPRODSUM) THEN !-- Near reproducible summation ITAG = 2001 IF (MPL_RANK == 1) THEN DO IPROC=2,MPL_NUMPROC CALL MPL_RECV(ZRECVBUF,KSOURCE=IPROC,KCOMM=ICOMM%MPI_VAL,KTAG=ITAG,& &KERROR=IERROR,KOUNT=ICOUNT) IF (ICOUNT /= ISENDCOUNT) THEN WRITE(MPL_ERRUNIT,'(A,I10,A,I6,A,I10)')& & 'MPL_ALLREDUCE: RECEIVED UNEXPECTED NUMBER OF ELEMENTS ', & & ICOUNT,' FROM PROC ',IPROC,'. EXPECTED=',ISENDCOUNT CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ENDDO ZRECVBUF(:) = PSENDBUF(:) ELSE CALL MPL_SEND(PSENDBUF,KDEST=1,KCOMM=ICOMM%MPI_VAL,KTAG=ITAG,KERROR=IERROR,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='MPLS_SEND') ENDIF ITAG = ITAG + 1 CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM%MPI_VAL,KROOT=1,KERROR=IERROR) ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,MPI_REAL4, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL4%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_REAL4%MPI_VAL) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:) = ZRECVBUF(:) DEALLOCATE(ZRECVBUF) END SUBROUTINE MPL_ALLREDUCE_REAL4 SUBROUTINE MPL_ALLREDUCE_REAL4_2D(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRM),INTENT(INOUT) :: PSENDBUF(:,:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRM) :: ZRECVBUF(SIZE(PSENDBUF(:,1)),SIZE(PSENDBUF(1,:))) INTEGER(KIND=JPIM) IPROC, ITAG, ICOUNT LOGICAL LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,IERROR INTEGER(KIND=JPIM) :: ITID TYPE(MPI_COMM) :: ICOMM TYPE(MPI_OP) :: IOPER IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(& & CDMESSAGE='MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(& & CDMESSAGE='MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) !#ifndef NAGFOR !IF (ISENDCOUNT > 0) THEN ! IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1)))-LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 4_JPIB*(ISENDCOUNT - 1) ) THEN ! CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ! ENDIF !ENDIF !#endif !IF (LLREPRODSUM) THEN !-- Near reproducible summation ! ITAG = 2001 ! IF (MPL_RANK == 1) THEN ! DO IPROC=2,MPL_NUMPROC ! CALL MPL_RECV(ZRECVBUF,KSOURCE=IPROC,KCOMM=ICOMM,KTAG=ITAG,& ! &KERROR=IERROR,KOUNT=ICOUNT) ! IF (ICOUNT /= ISENDCOUNT) THEN ! WRITE(MPL_ERRUNIT,'(A,I10,A,I6,A,I10)')& ! & 'MPL_ALLREDUCE: RECEIVED UNEXPECTED NUMBER OF ELEMENTS ', & ! & ICOUNT,' FROM PROC ',IPROC,'. EXPECTED=',ISENDCOUNT ! CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ! ENDIF ! PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ! ENDDO ! ZRECVBUF(:) = PSENDBUF(:) ! ELSE ! CALL MPL_SEND(PSENDBUF,KDEST=1,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& ! &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='MPLS_SEND') ! ENDIF ! ITAG = ITAG + 1 ! CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM,KROOT=1,KERROR=IERROR) !ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,MPI_REAL4, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,MPI_REAL4%MPI_VAL) CALL MPL_RECVSTATS(ISENDCOUNT,MPI_REAL4%MPI_VAL) ENDIF !ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:,:) = ZRECVBUF(:,:) END SUBROUTINE MPL_ALLREDUCE_REAL4_2D END MODULE MPL_ALLREDUCE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/ec_mpi_finalize.F900000664000175000017500000000343615157200431024113 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE EC_MPI_FINALIZE(KERROR,LDCALLFINITO,LDMEMINFO,CALLER) USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_COMM_WORLD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(OUT) :: KERROR LOGICAL, INTENT(IN) :: LDCALLFINITO LOGICAL, INTENT(IN) :: LDMEMINFO CHARACTER(LEN=*), INTENT(IN) :: CALLER LOGICAL :: LLINIT, LLFIN, LLNOTMPIWORLD INTEGER(KIND=JPIM) :: IERR TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: NCOMM_MEMINFO COMMON /cmn_meminfo/ NCOMM_MEMINFO #include "ec_meminfo.intfb.h" #include "dr_hook_end.intfb.h" KERROR = 0 IF (LDCALLFINITO) THEN !*** common MPI_Finalize() CALL MPI_INITIALIZED(LLINIT,IERR) IF (LLINIT .AND. IERR == 0) THEN CALL MPI_FINALIZED(LLFIN,IERR) IF (.NOT.LLFIN .AND. IERR == 0) THEN LLNOTMPIWORLD = (NCOMM_MEMINFO /= 0 .AND. NCOMM_MEMINFO /= MPI_COMM_WORLD%MPI_VAL) IF (LLNOTMPIWORLD) THEN ICOMM%MPI_VAL = NCOMM_MEMINFO ELSE ICOMM = MPI_COMM_WORLD ENDIF IF( LDMEMINFO ) CALL EC_MEMINFO(-1,"ec_mpi_finalize:"//caller,ICOMM%MPI_VAL,KBARR=1,KIOTASK=-1,KCALL=1) CALL DR_HOOK_END() ! Make sure DrHook output is produced before MPI_Finalize (in case it fails) CALL MPI_BARRIER(ICOMM,IERR) IF (LLNOTMPIWORLD) THEN ! CALL MPI_COMM_FREE(NCOMM_MEMINFO,IERR) NCOMM_MEMINFO = 0 ENDIF CALL MPI_FINALIZE(KERROR) ENDIF ENDIF ENDIF END SUBROUTINE EC_MPI_FINALIZE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_arg_mod.F900000664000175000017500000001377615157200431023266 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ARG_MOD !**** MPL_GETARG : A substitute for GET_COMMAND_ARGUMENT (formerly GETARG) for MPL applications ! MPL_IARGC : A substitute for function COMMAND_ARGUMENT_COUNT (formerly IARGC) for MPL applications ! Purpose. ! -------- ! MPL-task#1 calls GET_COMMAND_ARGUMENT until COMMAND_ARGUMENT_COUNT() arguments read ! or until the argument is a terminating argument ! Then arguments are passed on to other processors ! If MPL has not been initialized, it will be done now. !** Interface. ! ---------- ! CALL MPL_GETARG(KARG, CDARG) ! Input required arguments : ! ------------------------- ! KARG - The argument number requested (INTEGER(4)) ! Range : [ 0 .. MPL_IARGC() ] ! Output required arguments : ! --------------------------- ! CDARG - Return argument value (CHARACTER(LEN=*)) ! !** Interface. ! ---------- ! INUM_ARGS = MPL_IARGC() ! ! where INUM_ARGS is INTEGER(4) ! Author. ! ------- ! S.Saarinen, G.Mozdzynski ECMWF ! Modifications. ! -------------- ! Original: 2006-03-15 USE EC_PARKIND ,ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_COMM_WORLD, MPI_INTEGER, MPI_BYTE USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC,LINITMPI_VIA_MPL,LMPLUSERCOMM,MPLUSERCOMM IMPLICIT NONE PRIVATE CHARACTER(LEN=10), SAVE :: CL_TERMINATE = '-^' ! terminating argument INTEGER(KIND=JPIM), PARAMETER :: JP_ARGLEN = 1024 CHARACTER(LEN=JP_ARGLEN), ALLOCATABLE, SAVE :: CL_ARGS(:) INTEGER(KIND=JPIM), SAVE :: N_ARGS = -1 PUBLIC :: MPL_GETARG PUBLIC :: MPL_IARGC PUBLIC :: MPL_ARG_SET_CL_TERMINATE PUBLIC :: MPL_ARG_GET_CL_TERMINATE CONTAINS SUBROUTINE MPL_ARG_SET_CL_TERMINATE(CDTERM) CHARACTER(LEN=*), INTENT(IN) :: CDTERM CL_TERMINATE = CDTERM END SUBROUTINE MPL_ARG_SET_CL_TERMINATE SUBROUTINE MPL_ARG_GET_CL_TERMINATE(CDTERM) CHARACTER(LEN=*), INTENT(OUT) :: CDTERM CDTERM = CL_TERMINATE END SUBROUTINE MPL_ARG_GET_CL_TERMINATE SUBROUTINE INIT_ARGS() #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_INITIALIZED => MPI_INITIALIZED8, MPI_COMM_SIZE => MPI_COMM_SIZE8, & MPI_COMM_RANK => MPI_COMM_RANK8, MPI_BCAST => MPI_BCAST8, & MPI_INIT => MPI_INIT8 #endif INTEGER(KIND=JPIM) :: IARGS INTEGER(KIND=JPIM) :: IERROR, IROOT, ICOUNT INTEGER(KIND=JPIM) :: IRANK, INUMPROC, IRET, J INTEGER(KIND=JPIM) :: IARGC_C CHARACTER(LEN=LEN(CL_TERMINATE)) :: ENV_CL_TERMINATE CHARACTER(LEN=JP_ARGLEN) :: CLARG0 LOGICAL :: LLCARGS LOGICAL :: LLINIT TYPE(MPI_COMM) :: ICOMM IF (N_ARGS == -1) THEN IF (MPL_NUMPROC == -1) THEN ! This is complicated, but I hope it works: ! MPI has not yet been initialized, when this routines was called. ! Initialize MPI, but NOT via MPL_INIT to avoid recursion in MPL_IARGC() ! However, must pretend that MPL_INIT has actually initialized it, but ! MPL_NUMPROC will not be set CALL MPI_INITIALIZED(LLINIT,IRET) IF (LLINIT .EQV. .FALSE.) THEN CALL MPI_INIT(IERROR) LINITMPI_VIA_MPL = .TRUE. CALL EC_MPI_ATEXIT() ! ifsaux/support/endian.c: to make sure MPI_FINALIZE gets called ENDIF ENDIF ! If LMPLUSERCOMM is not set use MPI_COMM_WORLD IF (LMPLUSERCOMM) THEN ICOMM%MPI_VAL = MPLUSERCOMM ELSE ICOMM = MPI_COMM_WORLD ENDIF CALL MPI_COMM_SIZE(ICOMM,INUMPROC,IERROR) CALL MPI_COMM_RANK(ICOMM,IRANK,IERROR) IRANK=IRANK+1 IF (IRANK == 1 .OR. INUMPROC == 1) THEN CALL GET_ENVIRONMENT_VARIABLE('MPL_CL_TERMINATE',ENV_CL_TERMINATE) IF (ENV_CL_TERMINATE /= ' ') CL_TERMINATE = ENV_CL_TERMINATE IARGS = COMMAND_ARGUMENT_COUNT() LLCARGS = (IARGS < 0) ! Should be true for non-F90 main programs IF (LLCARGS) THEN IARGS = IARGC_C() LLCARGS = (IARGS >= 0) CALL GETARG_C(0,CLARG0) ! The executable name (see ifsaux/support/cargs.c) ELSE CALL PUTARG_INFO(IARGS, TRIM(CL_TERMINATE)) ! (see ifsaux/support/cargs.c) CALL GET_COMMAND_ARGUMENT(0,CLARG0) ! The executable name (normal F2003 way) CALL PUTARG_C(0,TRIM(CLARG0)) ! (see ifsaux/support/cargs.c) ENDIF IF (IARGS < 0) IARGS = 0 ALLOCATE(CL_ARGS(0:IARGS)) N_ARGS = 0 CL_ARGS(0) = CLARG0 DO J=1,IARGS ! Other args (repeat until end of loop or terminating argument found) IF (LLCARGS) THEN CALL GETARG_C(J,CL_ARGS(J)) ELSE CALL GET_COMMAND_ARGUMENT(J,CL_ARGS(J)) CALL PUTARG_C(J,TRIM(CL_ARGS(J))) ENDIF IF (CL_ARGS(J) == CL_TERMINATE) EXIT N_ARGS = N_ARGS + 1 ENDDO ENDIF IF (INUMPROC > 1) THEN IROOT = 0 IARGS = 0 IF (IRANK == 1) IARGS = N_ARGS ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(IARGS,1,MPI_INTEGER,IROOT,ICOMM,IERROR) ICOUNT = JP_ARGLEN IF (IRANK > 1) ALLOCATE(CL_ARGS(0:IARGS)) IF (IRANK > 1) CALL PUTARG_INFO(IARGS, TRIM(CL_TERMINATE)) DO J=0,IARGS ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(CL_ARGS(J),ICOUNT,MPI_BYTE,IROOT,ICOMM,IERROR) IF (IRANK > 1) CALL PUTARG_C(J,TRIM(CL_ARGS(J))) ENDDO IF (IRANK > 1) N_ARGS = IARGS ENDIF ENDIF END SUBROUTINE INIT_ARGS SUBROUTINE MPL_GETARG(KARG, CDARG) INTEGER(KIND=JPIM), INTENT(IN) :: KARG CHARACTER(LEN=*), INTENT(OUT) :: CDARG IF (N_ARGS == -1) CALL INIT_ARGS() IF (KARG >= 0 .AND. KARG <= N_ARGS) THEN CDARG = CL_ARGS(KARG) ELSE CDARG = ' ' ENDIF END SUBROUTINE MPL_GETARG FUNCTION MPL_IARGC() RESULT(IRET) INTEGER(KIND=JPIM) :: IRET IF (N_ARGS == -1) CALL INIT_ARGS() IRET = N_ARGS END FUNCTION MPL_IARGC END MODULE MPL_ARG_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_scatterv_mod.F900000664000175000017500000002426615157200431024344 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_SCATTERV_MOD !**** MPL_SCATTERV Scatter data from specific processor ! Purpose. ! -------- ! Scatter data from specific processor ! The data may be REAL*8,or INTEGER, one dimensional array ! !** Interface. ! ---------- ! CALL MPL_SCATTERV ! Input required arguments : ! ------------------------- ! PRECVBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PSENDBUF - buffer containing message ! (required from kroot) ! (can be type REAL*4, REAL*8 or INTEGER) ! KSENDCOUNTS-number of elements to be sent to each process ! (required from kroot processor) ! Input optional arguments : ! ------------------------- ! KROOT - rank of sending processor (default 1) ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KSENDDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_SCATTERV aborts when an error is detected. ! Author. ! ------- ! Y. Tremolet, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 02-03-13 ! M.Hamrud : 2014-10-22 : Add nonblocking option ! F. Vana 05-Mar-2015 Support for single precision ! --- *NOT* THREAD SAFE YET --- ! ---------------------------------------------------------------- USE EC_PARKIND, ONLY : JPRD, JPIM, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_DATATYPE, MPI_REQUEST, MPI_REAL4, MPI_REAL8, MPI_INTEGER USE MPL_DATA_MODULE, ONLY : MPL_RANK, MPL_COMM_OML, MPL_ERRUNIT, MPL_NUMPROC, MPL_METHOD, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MYRANK_MOD, ONLY : MPL_MYRANK USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE PUBLIC MPL_SCATTERV TYPE(MPI_COMM) :: ICOMM INTEGER(KIND=JPIM) :: IROOT,IPL_NUMPROC,IRECVCOUNT,ISENDBUFSIZE,IR,IPL_MYRANK,IMP_TYPE LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: IERROR,IDUM REAL(KIND=JPRD) :: ZDUM REAL(KIND=JPRM) :: ZDUM_4 INTEGER(KIND=JPIM) :: ZDUM_INT INTEGER(KIND=JPIM), ALLOCATABLE :: ONES(:) INTERFACE MPL_SCATTERV MODULE PROCEDURE MPL_SCATTERV_REAL8,MPL_SCATTERV_REAL4,MPL_SCATTERV_INTEGER END INTERFACE CONTAINS SUBROUTINE MPL_SCATTERV_PREAMB1(KCOMM,KROOT,KMP_TYPE,KREQUEST) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8, MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KMP_TYPE INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KREQUEST INTEGER(KIND=JPIM) :: ITID,ICOMM_SIZE,IERR ITID = OML_MY_THREAD() IERROR = 0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SCATTERV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF CALL MPI_COMM_SIZE(ICOMM, ICOMM_SIZE, IERR) IF (IERR /= 0) THEN CALL ABOR1('PROBLEM WITH SIZE OF ICOMM IN MPL_SCATTERV_PREAMB1') ELSE IF (.NOT. ALLOCATED(ONES)) THEN ALLOCATE(ONES(ICOMM_SIZE)) ONES(:) = 1_JPIM ENDIF ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SCATTERV: KREQUEST MISSING',LDABORT=LLABORT) ENDIF IF(ICOMM%MPI_VAL == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC IPL_MYRANK = MPL_RANK ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) IPL_MYRANK = MPL_MYRANK(ICOMM%MPI_VAL) ENDIF IF(PRESENT(KROOT)) THEN IROOT=KROOT ELSE IROOT=1 ENDIF END SUBROUTINE MPL_SCATTERV_PREAMB1 SUBROUTINE MPL_SCATTERV_PREAMB2(KSENDCOUNTS,KISENDDISPL,KSENDDISPL,KISENDDISPL_PT,CDSTRING) INTEGER(KIND=JPIM),INTENT(IN) :: KSENDCOUNTS(:) INTEGER(KIND=JPIM),TARGET,INTENT(IN),OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM),ALLOCATABLE,TARGET,INTENT(OUT) :: KISENDDISPL(:) INTEGER(KIND=JPIM),POINTER,INTENT(OUT),OPTIONAL :: KISENDDISPL_PT(:) CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING IF(SIZE(KSENDCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_SCATTERV: ERROR KSENDCOUNTS DIMENSION=',& & SIZE(KSENDCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_SCATTERV: ERROR KSENDCOUNTS DIMENSION IS WRONG',LDABORT=LLABORT) ENDIF IF(IRECVCOUNT /= KSENDCOUNTS(IPL_MYRANK)) THEN WRITE(MPL_ERRUNIT,*)'MPL_SCATTERV: ERROR KSENDCOUNTS INCONSISTENCY ',& & IRECVCOUNT,KSENDCOUNTS(IPL_MYRANK) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_SCATTERV: ERROR IRECVCOUNT /= KSENDCOUNTS(MPL_RANK) ',LDABORT=LLABORT) ENDIF IF(PRESENT(KSENDDISPL)) THEN KISENDDISPL_PT => KSENDDISPL(:) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC,KRECV_PT=KISENDDISPL_PT) ELSE ALLOCATE(KISENDDISPL(IPL_NUMPROC)) KISENDDISPL_PT => KISENDDISPL END IF KISENDDISPL_PT(1) = 0 DO IR=2, IPL_NUMPROC KISENDDISPL_PT(IR) = KISENDDISPL_PT(IR-1) + KSENDCOUNTS(IR-1) ENDDO ENDIF DO IR=1, IPL_NUMPROC IF(KISENDDISPL_PT(IR)+KSENDCOUNTS(IR) > ISENDBUFSIZE) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_SCATTERV:SEND BUFFER TOO SMALL ', & & IR,KISENDDISPL_PT(IR),KSENDCOUNTS(IR),ISENDBUFSIZE CALL MPL_MESSAGE(CDMESSAGE='MPL_SCATTERV',CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF ENDDO END SUBROUTINE MPL_SCATTERV_PREAMB2 ! ------------------------------------------------------------------ SUBROUTINE MPL_SCATTERV_REAL8(PRECVBUF,KROOT,PSENDBUF,KSENDCOUNTS,KSENDDISPL,& & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8 #endif REAL(KIND=JPRD), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT REAL(KIND=JPRD), INTENT(IN),OPTIONAL :: PSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN),TARGET,OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: ISENDDISPL(:) INTEGER(KIND=JPIM),POINTER :: ISENDDISPL_PT(:) TYPE(MPI_DATATYPE) :: IDATA_TYPE LOGICAL :: LLPRESENT_SENDBUF TYPE(MPI_REQUEST) :: IREQUEST_LOCAL IDATA_TYPE=MPI_REAL8 LLPRESENT_SENDBUF=PRESENT(PSENDBUF) #include "mpl_scatterv_array_tmpl.i90" END SUBROUTINE MPL_SCATTERV_REAL8 ! ------------------------------------------------------------------ SUBROUTINE MPL_SCATTERV_REAL4(PRECVBUF,KROOT,PSENDBUF,KSENDCOUNTS,KSENDDISPL,& & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8 #endif REAL(KIND=JPRM), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT REAL(KIND=JPRM), INTENT(IN),OPTIONAL :: PSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN),TARGET,OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: ISENDDISPL(:) INTEGER(KIND=JPIM),POINTER :: ISENDDISPL_PT(:) TYPE(MPI_DATATYPE) :: IDATA_TYPE LOGICAL :: LLPRESENT_SENDBUF TYPE(MPI_REQUEST) :: IREQUEST_LOCAL IDATA_TYPE=MPI_REAL4 LLPRESENT_SENDBUF=PRESENT(PSENDBUF) #include "mpl_scatterv_array_tmpl.i90" END SUBROUTINE MPL_SCATTERV_REAL4 SUBROUTINE MPL_SCATTERV_INTEGER(KRECVBUF,KROOT,KSENDBUF,KSENDCOUNTS,& & KSENDDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8 #endif INTEGER(KIND=JPIM), INTENT(OUT) :: KRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN),TARGET,OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: ISENDDISPL(:) INTEGER(KIND=JPIM),POINTER :: ISENDDISPL_PT(:) TYPE(MPI_DATATYPE) :: IDATA_TYPE LOGICAL :: LLPRESENT_SENDBUF TYPE(MPI_REQUEST) :: IREQUEST_LOCAL IDATA_TYPE=MPI_INTEGER LLPRESENT_SENDBUF=PRESENT(KSENDBUF) IF (PRESENT(KSENDBUF)) THEN ASSOCIATE(PRECVBUF=>KRECVBUF, PSENDBUF=>KSENDBUF) #include "mpl_scatterv_array_tmpl.i90" END ASSOCIATE ELSE ASSOCIATE(PRECVBUF=>KRECVBUF, PSENDBUF=>KRECVBUF) #include "mpl_scatterv_array_tmpl.i90" END ASSOCIATE END IF END SUBROUTINE MPL_SCATTERV_INTEGER ! ------------------------------------------------------------------ END MODULE MPL_SCATTERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpi4to8_m.F900000664000175000017500000025363515157200431022626 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI4TO8_M #ifdef USE_8_BYTE_WORDS USE EC_PARKIND, ONLY : JPIM, JPRM, JPRD IMPLICIT NONE PRIVATE :: STATUS8 INTEGER(KIND=8), DIMENSION(MPI_STATUS_SIZE) :: STATUS8 INTERFACE MPI_ALLGATHERV8 MODULE PROCEDURE MPI_ALLGATHERV8_R4, MPI_ALLGATHERV8_R8, & MPI_ALLGATHERV8_I4, MPI_ALLGATHERV8_I1 END INTERFACE MPI_ALLGATHERV8 INTERFACE MPI_ALLREDUCE8 MODULE PROCEDURE MPI_ALLREDUCE8_R4, MPI_ALLREDUCE8_R8, & MPI_ALLREDUCE8_I4, MPI_ALLREDUCE8_R4_2D, & MPI_ALLREDUCE8_R8_2D END INTERFACE MPI_ALLREDUCE8 INTERFACE MPI_ALLTOALLV8 MODULE PROCEDURE MPI_ALLTOALLV8_R8, MPI_ALLTOALLV8_I4 END INTERFACE MPI_ALLTOALLV8 INTERFACE MPI_BCAST8 MODULE PROCEDURE MPI_BCAST8_R4, MPI_BCAST8_R8, & MPI_BCAST8_I4, MPI_BCAST8_I1, & MPI_BCAST8_CH END INTERFACE MPI_BCAST8 INTERFACE MPI_BSEND8 MODULE PROCEDURE MPI_BSEND8_R4, MPI_BSEND8_R8, & MPI_BSEND8_R42, MPI_BSEND8_R82, & MPI_BSEND8_I4, MPI_BSEND8_I1, & MPI_BSEND8_CH, MPI_BSEND8_I42, & MPI_BSEND8_R4_1, MPI_BSEND8_R8_1 END INTERFACE MPI_BSEND8 INTERFACE MPI_ISEND8 MODULE PROCEDURE MPI_ISEND8_R4, MPI_ISEND8_R8, & MPI_ISEND8_R42, MPI_ISEND8_R82, & MPI_ISEND8_I4, MPI_ISEND8_I1, & MPI_ISEND8_CH, MPI_ISEND8_I42, & MPI_ISEND8_R4_1, MPI_ISEND8_R8_1 END INTERFACE MPI_ISEND8 INTERFACE MPI_SEND8 MODULE PROCEDURE MPI_SEND8_R4, MPI_SEND8_R8, & MPI_SEND8_R42, MPI_SEND8_R82, & MPI_SEND8_I4, MPI_SEND8_I1, & MPI_SEND8_CH, MPI_SEND8_I42, & MPI_SEND8_R4_1, MPI_SEND8_R8_1 END INTERFACE MPI_SEND8 INTERFACE MPI_FILE_IREAD_SHARED8 MODULE PROCEDURE MPI_FILE_IREAD_SHARED8_R8, MPI_FILE_IREAD_SHARED8_I4 END INTERFACE MPI_FILE_IREAD_SHARED8 INTERFACE MPI_FILE_IWRITE_SHARED8 MODULE PROCEDURE MPI_FILE_IWRITE_SHARED8_R8, MPI_FILE_IWRITE_SHARED8_I4 END INTERFACE MPI_FILE_IWRITE_SHARED8 INTERFACE MPI_FILE_READ_ORDERED8 MODULE PROCEDURE MPI_FILE_READ_ORDERED8_R8, MPI_FILE_READ_ORDERED8_I4 END INTERFACE MPI_FILE_READ_ORDERED8 INTERFACE MPI_FILE_READ_ORDERED_BEGIN8 MODULE PROCEDURE MPI_FREAD_ORDERED_BEGIN8_R8, MPI_FREAD_ORDERED_BEGIN8_I4 END INTERFACE MPI_FILE_READ_ORDERED_BEGIN8 INTERFACE MPI_FILE_READ_ORDERED_END8 MODULE PROCEDURE MPI_FREAD_ORDERED_END8_R8, MPI_FREAD_ORDERED_END8_I4 END INTERFACE MPI_FILE_READ_ORDERED_END8 INTERFACE MPI_FILE_READ_SHARED8 MODULE PROCEDURE MPI_FILE_READ_SHARED8_R8, MPI_FILE_READ_SHARED8_I4 END INTERFACE MPI_FILE_READ_SHARED8 INTERFACE MPI_FILE_WRITE_ORDERED8 MODULE PROCEDURE MPI_FILE_WRITE_ORDERED8_R8, MPI_FILE_WRITE_ORDERED8_I4 END INTERFACE MPI_FILE_WRITE_ORDERED8 INTERFACE MPI_FILE_WRITE_ORDERED_BEGIN8 MODULE PROCEDURE MPI_FWRITE_ORDERED_BEGIN8_R8, MPI_FWRITE_ORDERED_BEGIN8_I4 END INTERFACE MPI_FILE_WRITE_ORDERED_BEGIN8 INTERFACE MPI_FILE_WRITE_ORDERED_END8 MODULE PROCEDURE MPI_FWRITE_ORDERED_END8_R8, MPI_FWRITE_ORDERED_END8_I4 END INTERFACE MPI_FILE_WRITE_ORDERED_END8 INTERFACE MPI_FILE_WRITE_SHARED8 MODULE PROCEDURE MPI_FILE_WRITE_SHARED8_R8, MPI_FILE_WRITE_SHARED8_I4 END INTERFACE MPI_FILE_WRITE_SHARED8 INTERFACE MPI_GATHER8 MODULE PROCEDURE MPI_GATHER8_I1, MPI_GATHER8_R8_1 END INTERFACE MPI_GATHER8 INTERFACE MPI_GATHERV8 MODULE PROCEDURE MPI_GATHERV8_R4, MPI_GATHERV8_R8, & MPI_GATHERV8_R4S, MPI_GATHERV8_R8S, & MPI_GATHERV8_I4, MPI_GATHERV8_I1, & MPI_GATHERV8_I4S, MPI_GATHERV8_I4S_1, & MPI_GATHERV8_R8_1, MPI_GATHERV8_R8S_1 END INTERFACE MPI_GATHERV8 INTERFACE MPI_RECV8 MODULE PROCEDURE MPI_RECV8_R4, MPI_RECV8_R8, & MPI_RECV8_R42, MPI_RECV8_R82, & MPI_RECV8_I4, MPI_RECV8_I1, & MPI_RECV8_R4_1, MPI_RECV8_R8_1, & MPI_RECV8_CH, MPI_RECV8_I42 END INTERFACE MPI_RECV8 INTERFACE MPI_IRECV8 MODULE PROCEDURE MPI_IRECV8_R4, MPI_IRECV8_R8, & MPI_IRECV8_R42, MPI_IRECV8_R82, & MPI_IRECV8_I4, MPI_IRECV8_I1, & MPI_IRECV8_I42, & MPI_IRECV8_R4_1, MPI_IRECV8_R8_1, & MPI_IRECV8_CH END INTERFACE MPI_IRECV8 INTERFACE MPI_SCATTERV8 MODULE PROCEDURE MPI_SCATTERV8_R8, MPI_SCATTERV8_I4, & MPI_SCATTERV8_R8S, MPI_SCATTERV8_I4S END INTERFACE MPI_SCATTERV8 PUBLIC CONTAINS ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ALLREDUCE8_R4(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDDATA(:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & RECVDATA(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVDATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDDATA8 = SENDDATA COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA8, RECVDATA8, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_ALLREDUCE8_R4 SUBROUTINE MPI_ALLREDUCE8_R4_2D(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & SENDDATA(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRM), DIMENSION(:,:), INTENT(OUT) :: & RECVDATA(:.:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & SENDDATA8, RECVDATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDDATA8 = SENDDATA COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA8, RECVDATA8, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_ALLREDUCE8_R4_2D ! --------------------------------------------------------- SUBROUTINE MPI_ALLREDUCE8_R8(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDDATA(:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVDATA(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA, RECVDATA, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_ALLREDUCE8_R8 SUBROUTINE MPI_ALLREDUCE8_R8_2D(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & SENDDATA(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRD), DIMENSION(:,:), INTENT(OUT) :: & RECVDATA(:,:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA, RECVDATA, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_ALLREDUCE8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ALLREDUCE8_I4(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDDATA(:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVDATA(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVDATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDDATA8 = SENDDATA COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA8, RECVDATA8, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_ALLREDUCE8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_R4(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, RECVAREA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDAREA8 = SENDAREA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_R8(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_I4(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDAREA, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDAREA8 = SENDAREA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_I1(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDAREA8 = SENDAREA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_I1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ALLTOALLV8_R8(SENDAREA, SENDCOUNTS, SDISPLS, SENDTYPE, & RECVAREA, RECVCOUNTS, RDISPLS, RECVTYPE, & COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDCOUNTS, SDISPLS, RECVCOUNTS, RDISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVTYPE, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDCOUNTS8, SDISPLS8, RECVCOUNTS8, RDISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(SDISPLS8(SIZE(SDISPLS))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(RDISPLS8(SIZE(RDISPLS))) SENDCOUNTS8 = SENDCOUNTS SDISPLS8 = SDISPLS SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS RDISPLS8 = RDISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLTOALLV(SENDAREA, SENDCOUNTS8, SDISPLS8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, RDISPLS8, RECVTYPE8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(SENDCOUNTS8) DEALLOCATE(SDISPLS8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(RDISPLS8) END SUBROUTINE MPI_ALLTOALLV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ALLTOALLV8_I4(SENDAREA, SENDCOUNTS, SDISPLS, SENDTYPE, & RECVAREA, RECVCOUNTS, RDISPLS, RECVTYPE, & COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDAREA, SENDCOUNTS, SDISPLS, RECVCOUNTS, RDISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVTYPE, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, SENDCOUNTS8, SDISPLS8, RECVAREA8, RECVCOUNTS8, RDISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(SDISPLS8(SIZE(SDISPLS))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(RDISPLS8(SIZE(RDISPLS))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS SDISPLS8 = SDISPLS SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS RDISPLS8 = RDISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLTOALLV(SENDAREA8, SENDCOUNTS8, SDISPLS8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, RDISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(SENDCOUNTS8) DEALLOCATE(SDISPLS8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(RDISPLS8) END SUBROUTINE MPI_ALLTOALLV8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_R4(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) DATA = DATA8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BCAST8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_R8(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BCAST8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_I4(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) DATA = DATA8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BCAST8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_I1(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) DATA = DATA8 IERROR = IERROR8 END SUBROUTINE MPI_BCAST8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_CH(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) CHARACTER(LEN=*), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BCAST8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_R4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R8(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_R42 ! ========================================================= SUBROUTINE MPI_BSEND8_I42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_I42 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R82(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R82 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_I4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_I1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_I1 ! ========================================================= SUBROUTINE MPI_BSEND8_R4_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R4_1 ! ========================================================= SUBROUTINE MPI_BSEND8_R8_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R8_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_CH(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) CHARACTER(LEN=*), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_R4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R8(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_R42 ! ========================================================= SUBROUTINE MPI_ISEND8_I42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_I42 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R82(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R82 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_I4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_I4 ! ========================================================= SUBROUTINE MPI_ISEND8_R4_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8):: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R4_1 ! ========================================================= SUBROUTINE MPI_ISEND8_R8_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8) :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R8_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_I1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_I1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_CH(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) CHARACTER(LEN=*), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_R4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R8(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_R42 ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_I42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_I42 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R82(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R82 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_I4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_I1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_I1 ! ========================================================= SUBROUTINE MPI_SEND8_R4_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R4_1 ! ========================================================= SUBROUTINE MPI_SEND8_R8_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R8_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_CH(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) CHARACTER(LEN=*), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IREAD_SHARED8_R8(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IREAD_SHARED(FH8, BUF, COUNT8, DATATYPE8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_IREAD_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IREAD_SHARED8_I4(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IREAD_SHARED(FH8, BUF8, COUNT8, DATATYPE8, REQUEST8, IERROR8) BUF = BUF8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_IREAD_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IWRITE_SHARED8_R8(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & BUF INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IWRITE_SHARED(FH8, BUF, COUNT8, DATATYPE8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_IWRITE_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IWRITE_SHARED8_I4(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, BUF(:), COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH BUF8 = BUF COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IWRITE_SHARED(FH8, BUF8, COUNT8, DATATYPE8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_IWRITE_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_ORDERED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_READ_ORDERED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_ORDERED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) BUF = BUF8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_READ_ORDERED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_R8(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED_BEGIN(FH8, BUF, COUNT8, DATATYPE8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_I4(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED_BEGIN(FH8, BUF8, COUNT8, DATATYPE8, IERROR8) BUF = BUF8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_END8_R8(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, IERROR8 FH8 = FH CALL MPI_FILE_READ_ORDERED_END(FH8, BUF, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FREAD_ORDERED_END8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_END8_I4(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH CALL MPI_FILE_READ_ORDERED_END(FH8, BUF8, STATUS8, IERROR8) BUF = BUF8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FREAD_ORDERED_END8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_SHARED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_SHARED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_READ_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_SHARED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_SHARED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) BUF = BUF8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_READ_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_ORDERED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & BUF INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_WRITE_ORDERED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_ORDERED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, BUF(:), COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH BUF8 = BUF COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_WRITE_ORDERED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_R8(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED_BEGIN(FH8, BUF, COUNT8, DATATYPE8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_I4(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED_BEGIN(FH8, BUF8, COUNT8, DATATYPE8, IERROR8) BUF = BUF8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_END8_R8(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, STATUS(:) REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, IERROR8 FH8 = FH STATUS8 = STATUS CALL MPI_FILE_WRITE_ORDERED_END(FH8, BUF, STATUS8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FWRITE_ORDERED_END8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_END8_I4(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, STATUS(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH STATUS8 = STATUS CALL MPI_FILE_WRITE_ORDERED_END(FH8, BUF8, STATUS8, IERROR8) BUF = BUF8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FWRITE_ORDERED_END8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_SHARED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & BUF INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_SHARED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_WRITE_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_SHARED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, BUF(:), COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH BUF8 = BUF COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_SHARED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_WRITE_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_GATHER8_R8_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHER(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_GATHER8_R8_1 ! --------------------------------------------------------- SUBROUTINE MPI_GATHER8_I1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDDATA, SENDCOUNT, SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8) :: & SENDDATA8, RECVAREA8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHER(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 END SUBROUTINE MPI_GATHER8_I1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R8(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R8S(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_GATHERV8_R8S ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R4(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVAREA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R4S(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRM), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8 REAL(KIND=8) :: RECVAREA8 INTEGER(KIND=8) :: RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) END SUBROUTINE MPI_GATHERV8_R4S ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I4(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDDATA, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I4S(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8 INTEGER(KIND=8) :: & RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) END SUBROUTINE MPI_GATHERV8_I4S ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I4S_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8) :: & SENDDATA8 INTEGER(KIND=8) :: & RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 END SUBROUTINE MPI_GATHERV8_I4S_1 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDDATA, SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8) :: & SENDDATA8, RECVAREA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R8_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_R8_1 ! ========================================================= SUBROUTINE MPI_GATHERV8_R8S_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_GATHERV8_R8S_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R8(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_R42 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_I42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_I42 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R82(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R82 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_I4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & DATA, STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_I1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & DATA, IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R4_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS REAL(KIND=JPRM), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8) :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R4_1 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R8_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS REAL(KIND=JPRD), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R8_1 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_CH(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS CHARACTER(LEN=*), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_CH ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R8(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_R42 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R82(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R82 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_I4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & DATA(:), REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_I42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_I42 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_I1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & DATA, REQUEST, IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R4_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8) :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R4_1 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R8_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R8_1 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_CH(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM CHARACTER(LEN=*), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SCATTERV8_R8(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, RECVDATA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(SENDCOUNTS8) DEALLOCATE(DISPLS8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_SCATTERV8_R8S(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM, SENDCOUNTS, DISPLS REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVDATA8 REAL(KIND=8) :: & SENDAREA8 INTEGER(KIND=8) :: & SENDCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_R8S ! --------------------------------------------------------- SUBROUTINE MPI_SCATTERV8_I4(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDAREA, SENDCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, SENDCOUNTS8, DISPLS8, RECVDATA8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(SENDCOUNTS8) DEALLOCATE(DISPLS8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_I4 ! ========================================================= SUBROUTINE MPI_SCATTERV8_I4S(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDAREA, SENDCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & SENDAREA8, SENDCOUNTS8, DISPLS8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVDATA8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_I4S ! ========================================================= ! ========================================================= ! ========================================================= #endif END MODULE MPI4TO8_M fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_mpi.F900000664000175000017500000000072115157200431022425 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MPI USE MPI_F08 END MODULE MPL_MPI fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_alltoallv_mod.F900000664000175000017500000004153715157200431024503 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLTOALLV_MOD !**** MPL_ALLTOALLV - Everyone sends different data to everyone ! Purpose. ! -------- ! Interface to MPI_ALLTOALLV ! The data may be REAL*8,or INTEGER !** Interface. ! ---------- ! CALL MPL_ALLTOALLV ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*8 or INTEGER) ! PRECVBUF - buffer containing message ! (can be type REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! KSENDCOUNTS-number of elements to be sent to each process ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! KSENDDISPL -displacements in PSENDBUF from which to send ! the data ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_ALLTOALLV aborts when an error is detected. ! Author. ! ------- ! Y. Tremolet ! Modifications. ! -------------- ! Original: 02-03-21 ! Modified : 25-09-02 M.Hamrud - generalize ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_REQUEST, MPI_REAL4, MPI_REAL8, MPI_INTEGER USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_NUMPROC, MPL_ERRUNIT, MPL_METHOD, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IRECVCOUNT,ISENDCOUNT,IR,IMP_TYPE TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLSCALAR INTERFACE MPL_ALLTOALLV MODULE PROCEDURE MPL_ALLTOALLV_REAL8,MPL_ALLTOALLV_INTEGER,MPL_ALLTOALLV_REAL4 END INTERFACE PUBLIC MPL_ALLTOALLV CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,KISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,KIRECVDISPL,KIRECVDISPL_PT, & KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:),KSENDCOUNTS(:) INTEGER(KIND=JPIM),TARGET,INTENT(OUT) :: KISENDDISPL(:),KIRECVDISPL(:) INTEGER(KIND=JPIM),POINTER,INTENT(OUT) :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KSENDDISPL(:),KRECVDISPL(:),KCOMM,KMP_TYPE,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KSENDDISPL,KRECVDISPL INTEGER(KIND=JPIM) :: ITID,J ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLTOALLV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(ICOMM%MPI_VAL == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) ENDIF IF(SIZE(KRECVCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_ALLTOALLV: ERROR KRECVCOUNTS dimension=',& & SIZE(KRECVCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_ALLTOALLV: ERROR KRECVCOUNTS dimension is wrong',LDABORT=LLABORT) ENDIF IF(SIZE(KSENDCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_ALLTOALLV: ERROR KSENDCOUNTS dimension=',& & SIZE(KSENDCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_ALLTOALLV: ERROR KSENDCOUNTS dimension is wrong',LDABORT=LLABORT) ENDIF IF(PRESENT(KRECVDISPL)) THEN KIRECVDISPL_PT => KRECVDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC,KRECV_PT=KIRECVDISPL_PT) ELSE KIRECVDISPL_PT => KIRECVDISPL ENDIF KIRECVDISPL_PT(:) = 0 IF(LLSCALAR) THEN DO IR=2, IPL_NUMPROC KIRECVDISPL_PT(IR) = KIRECVDISPL_PT(IR-1) + 1 ENDDO ELSE DO IR=2, IPL_NUMPROC KIRECVDISPL_PT(IR) = KIRECVDISPL_PT(IR-1) + KRECVCOUNTS(IR-1) ENDDO ENDIF ENDIF DO IR=1, IPL_NUMPROC IF(KIRECVDISPL_PT(IR) < 0 .OR. KRECVCOUNTS(IR) < 0) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV: RECV.. < 0 ',& & IR,KIRECVDISPL_PT(IR),KRECVCOUNTS(IR) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(KIRECVDISPL_PT(IR)+KRECVCOUNTS(IR) > IRECVCOUNT) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV:RECV BUFFER TOO SMALL ', & & IR,KIRECVDISPL_PT(IR),KRECVCOUNTS(IR),IRECVCOUNT CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF ENDDO IF(PRESENT(KSENDDISPL)) THEN KISENDDISPL_PT => KSENDDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KSEND_PT = KISENDDISPL_PT,NO_NEW_NODE=.TRUE.) ELSE KISENDDISPL_PT => KISENDDISPL ENDIF KISENDDISPL_PT(:) = 0 IF(LLSCALAR) THEN DO IR=2, IPL_NUMPROC KISENDDISPL_PT(IR) = KISENDDISPL_PT(IR-1) + 1 ENDDO ELSE DO IR=2, IPL_NUMPROC KISENDDISPL_PT(IR) = KISENDDISPL_PT(IR-1) + KSENDCOUNTS(IR-1) ENDDO ENDIF ENDIF DO IR=1,IPL_NUMPROC IF(KISENDDISPL_PT(IR) < 0 .OR. KSENDCOUNTS(IR) < 0) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV:SEND.. <0 ',& & IR,KISENDDISPL_PT(IR),KSENDCOUNTS(IR) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(KISENDDISPL_PT(IR)+KSENDCOUNTS(IR) > ISENDCOUNT) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV:SEND BUFFER TOO SMALL ', & & IR,KISENDDISPL_PT(IR),KSENDCOUNTS(IR),ISENDCOUNT CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF ENDDO END SUBROUTINE MPL_ALLTOALLV_PREAMB SUBROUTINE MPL_ALLTOALLV_REAL8(PSENDBUF,KSENDCOUNTS,PRECVBUF,KRECVCOUNTS,& &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLTOALLV => MPI_ALLTOALLV8 #endif IMPLICIT NONE REAL(KIND=JPRD), INTENT(IN) :: PSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNTS(:), KRECVCOUNTS(:) REAL(KIND=JPRD), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KCOMM ,KMP_TYPE INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL, TARGET :: KSENDDISPL(:), KRECVDISPL(:) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM), INTENT(OUT),OPTIONAL :: KREQUEST,KERROR INTEGER(KIND=JPIM) :: IRECVDISPL(MPL_NUMPROC),ISENDDISPL(MPL_NUMPROC) INTEGER(KIND=JPIM),POINTER :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) TYPE(MPI_REQUEST) :: IREQUEST_LOCAL ISENDCOUNT=SIZE(PSENDBUF) IRECVCOUNT=SIZE(PRECVBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF IF( .NOT. IS_CONTIGUOUS(PRECVBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif LLSCALAR=.FALSE. IERROR=0 CALL MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,ISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,IRECVDISPL,KIRECVDISPL_PT,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLTOALLV(PSENDBUF(:),KSENDCOUNTS,KISENDDISPL_PT,MPI_REAL8, & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,MPI_REAL8,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR=KERROR,CDMESSAGE='MPL_ALLTOALLV',CDSTRING=' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IALLTOALLV(PSENDBUF(:),KSENDCOUNTS,KISENDDISPL_PT,MPI_REAL8, & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,MPI_REAL8,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF (.NOT. PRESENT(KSENDDISPL) .OR. .NOT. PRESENT(KRECVDISPL)) THEN ! in this case the preamble has set the linked list for the missing displacements CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) END IF ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(CDMESSAGE='ERROR IN MPL_ALLTOALLV',& & KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),MPI_REAL8%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_REAL8%MPI_VAL) ENDIF END SUBROUTINE MPL_ALLTOALLV_REAL8 SUBROUTINE MPL_ALLTOALLV_REAL4(PSENDBUF,KSENDCOUNTS,PRECVBUF,KRECVCOUNTS,& &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLTOALLV => MPI_ALLTOALLV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNTS(:), KRECVCOUNTS(:) REAL(KIND=JPRM), INTENT(IN) :: PSENDBUF(:) REAL(KIND=JPRM), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM ,KMP_TYPE INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL, TARGET :: KSENDDISPL(:), KRECVDISPL(:) CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM), INTENT(OUT),OPTIONAL :: KREQUEST,KERROR INTEGER(KIND=JPIM) :: IRECVDISPL(MPL_NUMPROC),ISENDDISPL(MPL_NUMPROC) INTEGER(KIND=JPIM),POINTER :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) TYPE(MPI_REQUEST) :: IREQUEST_LOCAL ISENDCOUNT=SIZE(PSENDBUF) IRECVCOUNT=SIZE(PRECVBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF IF( .NOT. IS_CONTIGUOUS(PRECVBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif LLSCALAR=.FALSE. IERROR=0 CALL MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,ISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,IRECVDISPL,KIRECVDISPL_PT,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLTOALLV(PSENDBUF,KSENDCOUNTS,KISENDDISPL_PT,MPI_REAL4, & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,MPI_REAL4,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLTOALLV(PSENDBUF,KSENDCOUNTS,KISENDDISPL_PT,MPI_REAL4, & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,MPI_REAL4,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF (.NOT. PRESENT(KSENDDISPL) .OR. .NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(CDMESSAGE='ERROR IN MPL_ALLTOALLV',& & KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),MPI_REAL4%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_REAL4%MPI_VAL) ENDIF END SUBROUTINE MPL_ALLTOALLV_REAL4 SUBROUTINE MPL_ALLTOALLV_INTEGER(KSENDBUF,KSENDCOUNTS,KRECVBUF,KRECVCOUNTS,& &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLTOALLV => MPI_ALLTOALLV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNTS(:), KRECVCOUNTS(:) INTEGER(KIND=JPIM), INTENT(OUT) :: KRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KSENDDISPL(:), KRECVDISPL(:), KCOMM,KMP_TYPE CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM), INTENT(OUT),OPTIONAL :: KREQUEST,KERROR INTEGER(KIND=JPIM) :: IRECVDISPL(MPL_NUMPROC),ISENDDISPL(MPL_NUMPROC) INTEGER(KIND=JPIM),POINTER :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) TYPE(MPI_REQUEST) :: IREQUEST_LOCAL ISENDCOUNT=SIZE(KSENDBUF) IRECVCOUNT=SIZE(KRECVBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KSENDBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF IF( .NOT. IS_CONTIGUOUS(KRECVBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif LLSCALAR=.FALSE. IERROR=0 CALL MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,ISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,IRECVDISPL,KIRECVDISPL_PT,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLTOALLV(KSENDBUF,KSENDCOUNTS,KISENDDISPL_PT,MPI_INTEGER, & & KRECVBUF,KRECVCOUNTS,KIRECVDISPL_PT,MPI_INTEGER,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR=KERROR,CDMESSAGE='MPL_ALLTOALLV',CDSTRING=' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IALLTOALLV(KSENDBUF,KSENDCOUNTS,KISENDDISPL_PT,MPI_INTEGER, & & KRECVBUF,KRECVCOUNTS,KIRECVDISPL_PT,MPI_INTEGER,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF (.NOT. PRESENT(KSENDDISPL) .OR. .NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) END IF ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(CDMESSAGE='ERROR IN MPL_ALLTOALLV',& & KERROR=IERROR,LDABORT=LLABORT) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),MPI_INTEGER%MPI_VAL) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),MPI_INTEGER%MPI_VAL) ENDIF END SUBROUTINE MPL_ALLTOALLV_INTEGER ! ------------------------------------------------------------------ END MODULE MPL_ALLTOALLV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_ioinit_mod.F900000664000175000017500000000657215157200431024004 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_IOINIT_MOD ! ! Purpose. initialise parallel IO environment ! -------- ! ! ! Interface. ! ---------- ! call mpl_ioinit(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kop - Style of parallel IO ! kstrout - Number of output processors ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_IOINIT) ! ! ----------------------------------------------------------------- ! USE EC_PARKIND, ONLY : JPIM USE MPL_MPI, ONLY : MPI_COMM, MPI_UNDEFINED USE MPL_DATA_MODULE, ONLY : MPL_RANK, MPL_COMM IMPLICIT NONE INTEGER(KIND=JPIM) :: MPL_NUMIO INTEGER(KIND=JPIM) :: MPL_IOP INTEGER(KIND=JPIM) :: MPL_COMM_IO PRIVATE PUBLIC :: MPL_IOINIT, MPL_NUMIO, MPL_IOP, MPL_COMM_IO CONTAINS SUBROUTINE MPL_IOINIT(KOP,KSTROUT,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SPLIT => MPI_COMM_SPLIT8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KOP,KSTROUT INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) :: COLOR,KEY TYPE(MPI_COMM) :: MPL_COMM_IO_INTERNAL,MPL_COMM_INTERNAL ! ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF(KOP < 1 .OR. KOP > 4) THEN KERROR = -1 RETURN ENDIF ! ! ----------------------------------------------------------------- ! ! 2. Check Style of Operation and take appropriate action ! ------------------------------------------------------- MPL_NUMIO = KSTROUT MPL_IOP = KOP IF(MPL_RANK <= KSTROUT) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED ENDIF KEY = 0 MPL_COMM_INTERNAL%MPI_VAL = MPL_COMM CALL MPI_COMM_SPLIT(MPL_COMM_INTERNAL,COLOR,KEY,MPL_COMM_IO_INTERNAL,KERROR) MPL_COMM=MPL_COMM_INTERNAL%MPI_VAL MPL_COMM_IO=MPL_COMM_IO_INTERNAL%MPI_VAL ! ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_IOINIT END MODULE MPL_IOINIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_scatterv_array_tmpl.i900000664000175000017500000000350115157200431025767 0ustar alastairalastairCALL MPL_SCATTERV_PREAMB1(KCOMM,KROOT,KMP_TYPE,KREQUEST) IRECVCOUNT=SIZE(PRECVBUF) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. LLPRESENT_SENDBUF) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_SCATTERV:SENDBUF MISSING',CDSTRING=CDSTRING,& & LDABORT=LLABORT) ISENDBUFSIZE=SIZE(PSENDBUF) CALL MPL_SCATTERV_PREAMB2(KSENDCOUNTS,ISENDDISPL,KSENDDISPL,ISENDDISPL_PT,& & CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_SCATTERV(PSENDBUF,KSENDCOUNTS,ISENDDISPL_PT,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_ISCATTERV(PSENDBUF,KSENDCOUNTS,ISENDDISPL_PT,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL IF(.NOT. PRESENT(KSENDDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),IDATA_TYPE%MPI_VAL) CALL MPL_RECVSTATS(IRECVCOUNT,IDATA_TYPE%MPI_VAL) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_SCATTERV(ZDUM_INT,ONES,ONES,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_ISCATTERV(ZDUM_INT,ONES,ONES,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ENDIF IF(LMPLSTATS) THEN CALL MPL_RECVSTATS(IRECVCOUNT,IDATA_TYPE%MPI_VAL) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(CDMESSAGE='MPL_SCATTERV',& & CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_barrier_mod.F900000664000175000017500000000535215157200431024132 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BARRIER_MOD !**** MPL_BARRIER - Barrier synchronisation ! Purpose. ! -------- ! Blocks the caller until all group members have called it. !** Interface. ! ---------- ! CALL MPL_BARRIER ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_BARRIER aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! Threadsafe: 2004-12-15, J.Hague ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_COMM_OML USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. PUBLIC MPL_BARRIER CONTAINS SUBROUTINE MPL_BARRIER(KCOMM,CDSTRING,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_BARRIER => MPI_BARRIER8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER :: IERROR,ITID TYPE(MPI_COMM) :: ICOMM IERROR = 0 ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE(CDSTRING=CDSTRING,& & CDMESSAGE='MPL_BARRIER: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF CALL MPI_BARRIER(ICOMM,IERROR) IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_BARRIER',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_BARRIER END MODULE MPL_BARRIER_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/ec_mpi_atexit.c0000664000175000017500000000223115157200431023464 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ec_mpi_atexit.c */ #include #include #include #include #include #include #include "mpl.h" /* A routine to be called at the very end in case MPI wasn't finalized */ /* Registered *only* by MPL_INIT */ /* Disable this feature via : export EC_MPI_ATEXIT=0 */ void ec_mpi_atexit_(void) { char *env = getenv("EC_MPI_ATEXIT"); int do_it = env ? atoi(env) : 1; static int callnum = 0; ++callnum; if (do_it) { if (callnum == 1) { /* register */ atexit(ec_mpi_atexit_); } else if (callnum == 2) { /* action : finish MPI via F90 mpl_end (in mpl_bindc.F90) */ mpl_end(); } } } void ec_mpi_atexit(void) { ec_mpi_atexit_(); } fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_buffer_method_mod.F900000664000175000017500000001062715157200431025316 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BUFFER_METHOD_MOD !**** MPL_BUFFER_METHOD Establish message passing default method ! Purpose. ! -------- ! Setup the message passing buffering ! by allocating an attached buffer if required. !** Interface. ! ---------- ! CALL MPL_BUFFER_METHOD ! Input required arguments : ! ------------------------- ! KMP_TYPE - buffering type ! possible values are : ! JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED ! defined as parameters in MPL_DATA_MODULE ! Input optional arguments : ! ------------------------- ! KMBX_SIZE - Size (in bytes) of attached buffer ! if KMP_TYPE=JP_BLOCKING_BUFFERED ! KPROCIDS - array of processor ids ! LDINFO - = .TRUE. : Print informative msgs from MPL_INIT (default) ! = .FALSE. : Do not print ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_BUFFER_METHOD aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE,INTRINSIC :: ISO_C_BINDING, ONLY : C_PTR USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_ATTACHED_BUFFER, MPL_MBX_SIZE, MPL_METHOD, MPL_RANK, MPL_UNIT, MPL_IDS, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, JP_ATTACHED_BUFFER_BYTES USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_BUFFER_METHOD CONTAINS SUBROUTINE MPL_BUFFER_METHOD(KMP_TYPE,KMBX_SIZE,KERROR,KPROCIDS,LDINFO) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_BUFFER_DETACH => MPI_BUFFER_DETACH8, MPI_BUFFER_ATTACH => MPI_BUFFER_ATTACH8 #endif USE EC_PARKIND ,ONLY : JPIM INTEGER(KIND=JPIM),INTENT(IN) :: KMP_TYPE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KMBX_SIZE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROCIDS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KERROR LOGICAL, OPTIONAL,INTENT(IN) :: LDINFO INTEGER(KIND=JPIM) :: IMBX_DEFAULT_SIZE = 1000000 INTEGER(KIND=JPIM) :: IBUFFMPI,IERROR,ILEN LOGICAL :: LLABORT=.TRUE., LLINFO TYPE(C_PTR) :: MPL_ATTACHED_BUFFER_ADDRESS IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_BUFFER_METHOD: MPL NOT INITIALISED ',LDABORT=LLABORT) IF (ALLOCATED(MPL_ATTACHED_BUFFER)) THEN CALL MPI_BUFFER_DETACH(MPL_ATTACHED_BUFFER_ADDRESS,MPL_MBX_SIZE,IERROR) DEALLOCATE(MPL_ATTACHED_BUFFER) ENDIF IF(PRESENT(LDINFO)) THEN LLINFO = LDINFO ELSE LLINFO = .TRUE. ENDIF IF(KMP_TYPE == JP_BLOCKING_STANDARD) THEN IBUFFMPI=MPL_MBX_SIZE ELSE IF(KMP_TYPE == JP_BLOCKING_BUFFERED) THEN IBUFFMPI=KMBX_SIZE IF(IBUFFMPI == 0) IBUFFMPI=IMBX_DEFAULT_SIZE ! convert to bytes ILEN = (IBUFFMPI-1)/JP_ATTACHED_BUFFER_BYTES+1 ALLOCATE(MPL_ATTACHED_BUFFER(ILEN)) #ifdef OPS_COMPILE IERROR = 0 #else CALL MPI_BUFFER_ATTACH(MPL_ATTACHED_BUFFER,IBUFFMPI,IERROR) #endif IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF( IERROR /= 0 )THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BUFFER_METHOD ',CDSTRING='MPI_BUFFER_ATTACH ERROR',KERROR=IERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE ! invalid type IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_BUFFER_METHOD',CDSTRING='INVALID KMP_TYPE=',KERROR=KMP_TYPE,LDABORT=LLABORT) ENDIF ENDIF MPL_MBX_SIZE=IBUFFMPI MPL_METHOD=KMP_TYPE IF (MPL_RANK == 1) THEN IF (LLINFO) WRITE(MPL_UNIT,'(A,I2,I12)') 'MPL_BUFFER_METHOD: ',MPL_METHOD,MPL_MBX_SIZE ENDIF IF(PRESENT(KPROCIDS)) THEN IF(SIZE(KPROCIDS) < MPL_NUMPROC) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BUFFER_METHOD: KPROCIDS NOT CORRECT',LDABORT=LLABORT) ELSE MPL_IDS=KPROCIDS ENDIF ENDIF RETURN END SUBROUTINE MPL_BUFFER_METHOD END MODULE MPL_BUFFER_METHOD_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_f08/mpl_send_mod.F900000664000175000017500000013155615157200431023443 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_SEND_MOD !**** MPL_SEND Send a message ! Purpose. ! -------- ! Send a message to a named source from a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_SEND ! Input required arguments : ! ------------------------- ! PBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KTAG - message tag ! KDEST - rank of process to receive the message ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_SEND aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P. Marguinaud : 01-Jan-2011 : Do not raise an error when ! the numproc is beyond model limits and KCOMM is passed ! as argument ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPI, ONLY : MPI_COMM, MPI_REQUEST, MPI_REAL4, MPI_REAL8, MPI_INTEGER, MPI_INTEGER8, MPI_BYTE USE MPL_DATA_MODULE, ONLY : MPL_OUTPUT, MPL_COMM_OML, MPL_ERRUNIT, MPL_UNIT, MPL_METHOD, MPL_NUMPROC, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, JP_BLOCKING_SYNCHRONOUS, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_NPROC_MOD, ONLY : MPL_NPROC USE MPL_STATS_MOD, ONLY : MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS IMPLICIT NONE PRIVATE !---Moved into subroutines to keep threadsafe---- ! INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR ! LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_SEND MODULE PROCEDURE MPL_SEND_REAL4, MPL_SEND_REAL8,& & MPL_SEND_INT, MPL_SEND_REAL42, MPL_SEND_REAL43, & & MPL_SEND_REAL82,MPL_SEND_REAL83, MPL_SEND_INT_SCALAR, & & MPL_SEND_INT2, MPL_SEND_CHAR_SCALAR, & & MPL_SEND_REAL4_SCALAR, MPL_SEND_REAL8_SCALAR, & & MPL_SEND_INT8, MPL_SEND_CHAR END INTERFACE PUBLIC MPL_SEND CONTAINS SUBROUTINE MPL_SEND_REAL4(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_m,intent(in) :: PBUF(:) REAL(KIND=JPRM) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL4 SUBROUTINE MPL_SEND_REAL8(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:) REAL(KIND=JPRD) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL8 SUBROUTINE MPL_SEND_INT(KBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIM) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID,IDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT SUBROUTINE MPL_SEND_INT2(KBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIM) :: KBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID,IDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(IDUM,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KBUF,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT2 SUBROUTINE MPL_SEND_INT8(KBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIB) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIB) :: IDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(KBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(KBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER8%MPI_VAL) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(IDUM,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(IDUM,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(IDUM,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(IDUM,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(IDUM,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KBUF,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KBUF,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KBUF,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KBUF,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KBUF,ICOUNT,MPI_INTEGER8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT8 SUBROUTINE MPL_SEND_INT_SCALAR(KINT,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIM) :: KINT INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = 1 IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_INTEGER%MPI_VAL) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KINT,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KINT,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KINT,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KINT,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KINT,ICOUNT,MPI_INTEGER,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT_SCALAR SUBROUTINE MPL_SEND_REAL42(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_m,intent(in) :: PBUF(:,:) REAL(KIND=JPRM) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL42 SUBROUTINE MPL_SEND_REAL43(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:,:,:) REAL(KIND=JPRM) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF(KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL).AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL43 SUBROUTINE MPL_SEND_REAL82(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:,:) REAL(KIND=JPRD) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL82 SUBROUTINE MPL_SEND_CHAR_SCALAR(CDCHAR,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif CHARACTER(LEN=*) :: CDCHAR INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = LEN(CDCHAR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_CHAR_SCALAR SUBROUTINE MPL_SEND_CHAR(CDCHAR,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif CHARACTER(LEN=*) :: CDCHAR(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = LEN(CDCHAR) * SIZE(CDCHAR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_BYTE%MPI_VAL) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(CDCHAR,ICOUNT,MPI_BYTE,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_CHAR SUBROUTINE MPL_SEND_REAL4_SCALAR(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif REAL(KIND=JPRM) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = 1 IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL4%MPI_VAL) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL4,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL4_SCALAR SUBROUTINE MPL_SEND_REAL8_SCALAR(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif REAL(KIND=JPRD) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = 1 IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL8_SCALAR SUBROUTINE MPL_SEND_REAL83(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:,:,:) REAL(KIND=JPRD) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TYPE(MPI_REQUEST) :: IREQUEST_LOCAL INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,IERROR TYPE(MPI_COMM) :: ICOMM LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM%MPI_VAL=KCOMM ELSE ICOMM%MPI_VAL=MPL_COMM_OML(ITID) ENDIF IF(KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM%MPI_VAL).AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,MPI_REAL8%MPI_VAL) ENDIF #ifdef MPL_CHECK_CONTIG IF( .NOT. IS_CONTIGUOUS(PBUF) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM, & & IREQUEST_LOCAL,IERROR) KREQUEST=IREQUEST_LOCAL%MPI_VAL ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,MPI_REAL8,KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=' INVALID METHOD',KERROR=KERROR,LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND',CDSTRING=CDSTRING,KERROR=IERROR,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL83 END MODULE MPL_SEND_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/0000775000175000017500000000000015157200431022213 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_comm_compare_mod.F900000664000175000017500000000264315157200431026650 0ustar alastairalastair! (C) Copyright 2023- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_COMPARE_MOD !**** *MPL_COMM_COMPARE_MOD* - Compare two communicators ! Author. ! ------- ! Willem Deconinck *ECMWF* ! Original : 31-08-2023 USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_CONGRUENT, MPI_IDENT, MPI_SIMILAR IMPLICIT NONE PRIVATE PUBLIC :: MPL_COMM_COMPARE CONTAINS SUBROUTINE MPL_COMM_COMPARE (KCOMM1, KCOMM2, KRES, KERR, CDSTRING) INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM1 INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM2 INTEGER (KIND=JPIM), INTENT (OUT) :: KRES INTEGER (KIND=JPIM), INTENT (OUT) :: KERR CHARACTER (LEN=*), INTENT (IN), OPTIONAL :: CDSTRING CALL MPI_COMM_COMPARE (KCOMM1, KCOMM2, KRES, KERR) if( KRES == MPI_IDENT ) THEN KRES = 0 ! contexts and groups are the same ELSEIF (KRES == MPI_CONGRUENT) THEN KRES = 1 ! different contexts but identical groups ELSEIF (KRES == MPI_SIMILAR) THEN KRES = 2 ! different contexts but similar groups ELSE ! (KRES == MPI_UNEQUAL) THEN KRES = 3 ! otherwise ENDIF END SUBROUTINE MPL_COMM_COMPARE END MODULE MPL_COMM_COMPARE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_locomm_create_mod.F900000664000175000017500000000471615157200431027023 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_LOCOMM_CREATE_MOD !**** MPL_LOCOMM_CREATE Create a new communicator ! Purpose. ! -------- ! Create a new communicator from lowest N tasks in MPI_COMM_WORLD ! and set as default !** Interface. ! ---------- ! CALL MPL_LOCOMM_CREATE ! Input required arguments : ! ------------------------- ! N - Number of tasks in New Communicator ! Input optional arguments : ! ------------------------- ! Output required arguments : ! ------------------------- ! KCOMM - New Communicator ! Output optional arguments : ! ------------------------- ! MPL_LOCOMM_CREATE aborts when an error is detected. ! Author. ! ------- ! J.Hague ! Modifications. ! -------------- ! Original: 21/07/2003 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_COMM USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_LOCOMM_CREATE CONTAINS SUBROUTINE MPL_LOCOMM_CREATE(N,KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_GROUP => MPI_COMM_GROUP8, MPI_GROUP_INCL => MPI_GROUP_INCL8, MPI_COMM_CREATE => MPI_COMM_CREATE8 #endif INTEGER(KIND=JPIM),INTENT(OUT) :: KCOMM INTEGER(KIND=JPIM),INTENT(IN) :: N INTEGER(KIND=JPIM) :: IRANK(N) INTEGER(KIND=JPIM) :: J, IER, IGROUP, MPI_GROUP_WORLD LOGICAL :: LLABORT=.TRUE. DO J=1,N IRANK(J)=J-1 ENDDO CALL MPI_COMM_GROUP(MPL_COMM,MPI_GROUP_WORLD,IER) IF (IER/=0) CALL MPL_MESSAGE(IER,'MPL_LOCOMM_CREATE: MPI_COMM_GROUP',LDABORT=LLABORT) CALL MPI_GROUP_INCL(MPI_GROUP_WORLD,N,IRANK,IGROUP,IER) IF (IER/=0) CALL MPL_MESSAGE(IER,'MPL_LOCOMM_CREATE: MPI_GROUP_INCL',LDABORT=LLABORT) CALL MPI_COMM_CREATE(MPL_COMM,IGROUP,KCOMM,IER) IF (IER/=0) CALL MPL_MESSAGE(IER,'MPL_LOCOMM_CREATE: MPI_COMM_CREATE',LDABORT=LLABORT) RETURN END SUBROUTINE MPL_LOCOMM_CREATE END MODULE MPL_LOCOMM_CREATE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/ec_mpi_finalize.intfb.h0000664000175000017500000000131415157200431026601 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE EC_MPI_FINALIZE(KERROR,LDCALLFINITO,LDMEMINFO,CALLER) USE EC_PARKIND, ONLY : JPIM INTEGER(KIND=JPIM), INTENT(OUT) :: KERROR LOGICAL, INTENT(IN) :: LDCALLFINITO LOGICAL, INTENT(IN) :: LDMEMINFO CHARACTER(LEN=*), INTENT(IN) :: CALLER END SUBROUTINE EC_MPI_FINALIZE END INTERFACE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_abort_mod.F900000664000175000017500000000350215157200431025311 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ABORT_MOD USE OML_MOD, ONLY : OML_MY_THREAD, OML_MAX_THREADS USE EC_PARKIND, ONLY : JPIM USE YOMHOOK, ONLY : LHOOK USE MPL_MPIF, ONLY : MPI_COMM_WORLD USE MPL_DATA_MODULE, ONLY : MPL_ERRUNIT, MPL_UNIT PRIVATE PUBLIC MPL_ABORT INTEGER(KIND=JPIM), SAVE :: MAB_CNT = 0 ! Must be used with OMP FLUSH inside the OMP CRITICAL regions CONTAINS SUBROUTINE MPL_ABORT(CDMESSAGE) IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDMESSAGE INTEGER(KIND=JPIM) :: IRETURN_CODE,IERROR,ITID,INUMTH,IPROC,INUM_PROC LOGICAL :: LMPI_INITIALIZED IPROC=1 INUM_PROC=1 CALL MPI_INITIALIZED(LMPI_INITIALIZED,IERROR) IF( LMPI_INITIALIZED ) THEN CALL MPI_COMM_RANK(MPI_COMM_WORLD,IPROC,IERROR) IPROC = IPROC+1 ! 1-based in IFS context CALL MPI_COMM_SIZE(MPI_COMM_WORLD,INUM_PROC,IERROR) ENDIF ITID=OML_MY_THREAD() INUMTH=OML_MAX_THREADS() CALL EC_FLUSH(MPL_UNIT) !------Traceback from only one thread !$OMP CRITICAL (CRIT_MPL_ABORT) !$OMP FLUSH(MAB_CNT) IF (MAB_CNT == 0) THEN IF(PRESENT(CDMESSAGE)) THEN WRITE(MPL_ERRUNIT,'(A,I0,A,I0,A,A)') 'MPL_ABORT [PROC=',IPROC,',THRD=',ITID, '] : ', CDMESSAGE ELSE WRITE(MPL_ERRUNIT,'(A,I0,A,I0,A)') 'MPL_ABORT [PROC=',IPROC,',THRD=',ITID, ']' ENDIF CALL EC_FLUSH(MPL_ERRUNIT) MAB_CNT=1 !$OMP FLUSH(MAB_CNT) CALL TABORT() ! tabort.c : does not hang -- never returns ENDIF !$OMP END CRITICAL (CRIT_MPL_ABORT) END SUBROUTINE MPL_ABORT END MODULE MPL_ABORT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_probe_mod.F900000664000175000017500000001137115157200431025314 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_PROBE_MOD !**** MPL_PROBE - Check for incoming message ! Purpose. ! -------- ! Look for existence of an incoming message. !** Interface. ! ---------- ! CALL MPL_PROBE ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! KSOURCE - rank of process sending the message ! default is MPI_ANY_SOURCE ! KTAG - tag of incoming message ! default is MPI_ANY_TAG ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! LDWAIT - = TRUE : waits for a message to be available ! = FALSE: return immediately and set ! LDFLAG to indicate if a message exists ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_PROBE aborts when an error is detected. ! LDFLAG - must be supplied if LDWAIT=false ! = TRUE if a message exists ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P. Marguinaud : 01-Jan-2011 : Extends original interface with ! KCOUNT,KRECVTAG,KFROM (same meaning as ! in all MPL_* routines) ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_CHARACTER, MPI_TAG, MPI_SOURCE, MPI_STATUS_SIZE USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_COMM_OML USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PUBLIC MPL_PROBE PRIVATE !--- Moved into subroutine to make thrreadsafe---- ! INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) ! INTEGER(KIND=JPIM) :: ICOMM,ITAG,ISOURCE,IERROR ! LOGICAL :: LLWAIT,LLABORT=.TRUE. CONTAINS SUBROUTINE MPL_PROBE(KSOURCE,KTAG,KCOMM,LDWAIT,LDFLAG,CDSTRING,KERROR,KCOUNT,KRECVTAG,KFROM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_PROBE => MPI_PROBE8, MPI_IPROBE => MPI_IPROBE8 #endif INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KSOURCE,KTAG,KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR LOGICAL,INTENT(IN), OPTIONAL :: LDWAIT LOGICAL,INTENT(OUT),OPTIONAL :: LDFLAG CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KCOUNT, KRECVTAG, KFROM INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) INTEGER(KIND=JPIM) :: ICOMM,ITAG,ISOURCE,IERROR LOGICAL :: LLWAIT,LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_PROBE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KSOURCE)) THEN ISOURCE=KSOURCE-1 ELSE ISOURCE=MPI_ANY_SOURCE ENDIF IF(PRESENT(KTAG)) THEN ITAG=KTAG ELSE ITAG=MPI_ANY_TAG ENDIF IF(PRESENT(LDWAIT)) THEN LLWAIT=LDWAIT ELSE LLWAIT=.TRUE. ENDIF IF(LLWAIT) THEN CALL MPI_PROBE(ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) IF (IERROR == 0) THEN IF (PRESENT (KCOUNT)) CALL MPI_GET_COUNT (IRECV_STATUS, MPI_CHARACTER, KCOUNT, IERROR) IF (PRESENT (KRECVTAG)) KRECVTAG = IRECV_STATUS(MPI_TAG) IF (PRESENT (KFROM)) KFROM = IRECV_STATUS(MPI_SOURCE)+1 ENDIF ELSE IF(PRESENT(LDFLAG)) THEN CALL MPI_IPROBE(ISOURCE,ITAG,ICOMM,LDFLAG,IRECV_STATUS,IERROR) IF (IERROR == 0 .AND. LDFLAG) THEN IF (PRESENT (KCOUNT)) CALL MPI_GET_COUNT (IRECV_STATUS, MPI_CHARACTER, KCOUNT, IERROR) IF (PRESENT (KRECVTAG)) KRECVTAG = IRECV_STATUS(MPI_TAG) IF (PRESENT (KFROM)) KFROM = IRECV_STATUS(MPI_SOURCE)+1 ENDIF ELSE CALL MPL_MESSAGE(IERROR,'MPL_PROBE: MUST PROVIDE LDFLAG ',CDSTRING, & & LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_PROBE',CDSTRING,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_PROBE END MODULE MPL_PROBE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_comm_free_mod.F900000664000175000017500000000173415157200431026143 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_FREE_MOD !**** *MPL_COMM_FREE_MOD* - Release ressources used by a communicator ! Author. ! ------- ! Philippe Marguinaud *METEO FRANCE* ! Original : 11-09-2012 USE EC_PARKIND, ONLY : JPIM IMPLICIT NONE PRIVATE PUBLIC :: MPL_COMM_FREE CONTAINS SUBROUTINE MPL_COMM_FREE (KCOMM, KERR, CDSTRING) INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM INTEGER (KIND=JPIM), INTENT (OUT) :: KERR CHARACTER (LEN=*), INTENT (IN), OPTIONAL :: CDSTRING CALL MPI_COMM_FREE (KCOMM, KERR) END SUBROUTINE MPL_COMM_FREE END MODULE MPL_COMM_FREE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_message_mod.F900000664000175000017500000000557115157200431025636 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MESSAGE_MOD !**** MPL_MESSAGE - Prints message ! Purpose. ! -------- ! Creates an ASCII message for printing and optionally aborts !** Interface. ! ---------- ! CALL MPL_MESSAGE ! Input required arguments : ! ------------------------- ! CDMESSAGE- character string for message ! Input optional arguments : ! ------------------------- ! KERROR - Error number ! CDSTRING - Optional additional message ! prepended to CDMESSAGE ! LDABORT - forces ABORT if true ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE MPL_MPIF, ONLY : MPI_MAX_ERROR_STRING USE MPL_DATA_MODULE, ONLY : MPL_RANK, MPL_UNIT USE MPL_ABORT_MOD, ONLY : MPL_ABORT USE EC_PARKIND ,ONLY : JPIM PRIVATE PUBLIC MPL_MESSAGE CONTAINS SUBROUTINE MPL_MESSAGE(KERROR,CDMESSAGE,CDSTRING,LDABORT) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ERROR_STRING => MPI_ERROR_STRING8 #endif IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN) :: CDMESSAGE CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING LOGICAL ,INTENT(IN),OPTIONAL :: LDABORT CHARACTER*(MPI_MAX_ERROR_STRING) :: CLMPI_ERROR CHARACTER*12 :: CLERROR INTEGER(KIND=JPIM) :: IRESULTLEN,IERROR IF(PRESENT(KERROR)) THEN WRITE(CLERROR,'(I0)') KERROR ELSE CLERROR=' ' ENDIF IF(PRESENT(CDSTRING)) THEN WRITE(MPL_UNIT,'(4(1X,A),I0)') CDSTRING,CDMESSAGE,CLERROR, & & ' FROM PROCESSOR ',MPL_RANK ELSE WRITE(MPL_UNIT,'(3(1X,A),I0)') CDMESSAGE,CLERROR, & & ' FROM PROCESSOR ',MPL_RANK ENDIF IF(PRESENT(KERROR)) THEN CALL MPI_ERROR_STRING(KERROR,CLMPI_ERROR,IRESULTLEN,IERROR) WRITE(MPL_UNIT,'(1X,2A,I0)') CLMPI_ERROR(1:IRESULTLEN),' in processor ',MPL_RANK ELSE CLMPI_ERROR=' ' IRESULTLEN=1 ENDIF IF(PRESENT(LDABORT)) THEN IF(LDABORT) THEN WRITE(0,'(1X,2A,I0)') CLMPI_ERROR(1:IRESULTLEN),' in processor ',MPL_RANK CALL MPL_ABORT('ABORT') ENDIF ENDIF RETURN END SUBROUTINE MPL_MESSAGE END MODULE MPL_MESSAGE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_allgatherv_preamble.i900000664000175000017500000000223515157200431027410 0ustar alastairalastairIF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(ICOMM == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV: KREQUEST MISSING',LDABORT=LLABORT) ENDIF IF(PRESENT(KRECVDISPL)) THEN IRECVDISPL_PT => KRECVDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC, KRECV_PT=IRECVDISPL_PT) ELSE ALLOCATE(IRECVDISPL(IPL_NUMPROC)) IRECVDISPL_PT => IRECVDISPL END IF IRECVDISPL_PT(1) = 0 IF (LKRECVCOUNTS) THEN DO IR=2, IPL_NUMPROC IRECVDISPL_PT(IR) = IRECVDISPL_PT(IR-1) + KRECVCOUNTS(IR-1) ENDDO ELSE ! needed only for _int_scalar version where KRECVCOUNTS is optional DO IR=2, IPL_NUMPROC IRECVDISPL_PT(IR) = IRECVDISPL_PT(IR-1) + IRECVCOUNTS(IR-1) ENDDO ENDIF ENDIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/yommplstats.F900000664000175000017500000000172215157200431025071 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE YOMMPLSTATS USE EC_PARKIND ,ONLY : JPRD, JPIM IMPLICIT NONE SAVE PRIVATE :: JPRD, JPIM PUBLIC ! ------------------------------------------------------------------ ! Module for communications statistics. ! Module is internal to the MPLSTATS package - ! routines MPL_SENDSTATS, MPL_RECVSTATS ! LMPLSTATS - TRUE for gathering communications statistics LOGICAL :: LMPLSTATS = .FALSE. REAL(KIND=JPRD), ALLOCATABLE :: MPLSENDBYTES(:), MPLRECVBYTES(:) INTEGER(KIND=JPIM), ALLOCATABLE :: MPLSENDNUM(:), MPLRECVNUM(:) END MODULE YOMMPLSTATS fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_allgather_mod.F900000664000175000017500000000567215157200431026157 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLGATHER_MOD !**** MPL_ALLGATHER Send data to all processes ! Purpose. ! -------- ! Send a message to all processes from a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_ALLGATHER ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PRECVBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_ALLGATHER aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-11-23 ! M.Hamrud : 2014-10-22 : Add nonblocking option ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE PRIVATE INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITAG LOGICAL :: LLBARRIER INTEGER(KIND=JPIM) :: IMAXMSG,JK,IMYPAIR,ICHUNKS,ISTS,ISTR,JMESS,ILENS,IENS,IOUNT,IMP_TYPE INTEGER(KIND=JPIM) :: ILIMIT,IBARRFREQ,IDUM PUBLIC MPL_ALLGATHER CONTAINS SUBROUTINE MPL_ALLGATHER() RETURN END SUBROUTINE MPL_ALLGATHER END MODULE MPL_ALLGATHER_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_allgatherv_mod.F900000664000175000017500000003231015157200431026332 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLGATHERV_MOD !**** MPL_ALLGATHERV Send data to all processes ! Purpose. ! -------- ! Send a message to all processes from a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_ALLGATHERV ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PRECVBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_ALLGATHERV aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-11-23 ! J.Hague: 2004-12-15 : Threadsafe ! M.Hamrud: 2014-10-22 : Add nonblocking option ! F.Vana: 2015-03-05 : Support for single precision ! P.Gillies: 2018-05-30 : Add KSENDCOUNT argument, needed for zero length sends ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM ,JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_INTEGER, MPI_REAL4, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_METHOD, MPL_NUMPROC, MPL_OUTPUT, MPL_UNIT, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_ALLGATHERV MODULE PROCEDURE MPL_ALLGATHERV_REAL8,MPL_ALLGATHERV_REAL4,& MPL_ALLGATHERV_INT, MPL_ALLGATHERV_INT_SCALAR END INTERFACE PUBLIC MPL_ALLGATHERV CONTAINS SUBROUTINE MPL_ALLGATHERV_REAL4(PSENDBUF,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE REAL(KIND=JPRM) :: PSENDBUF(:) REAL(KIND=JPRM) :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM), TARGET, ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS = .true. ! .TRUE. if KRECVCOUNTS is present (used in _int_scalar version) INTEGER(KIND=JPIM) :: IRECVCOUNTS(1) ! needed for _int_scalar version preamble ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = SIZE(PSENDBUF) ISENDCOUNT = MAX(0,ISENDCOUNT) ! Bug? on IBM ENDIF IRECVCOUNT = SIZE(PRECVBUF) !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !--------- End of Preamble -------------- IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(PSENDBUF(1),ISENDCOUNT,INT(MPI_REAL4),PRECVBUF(1),& & KRECVCOUNTS,IRECVDISPL_PT,INT(MPI_REAL4),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(PSENDBUF(1),ISENDCOUNT,INT(MPI_REAL4),PRECVBUF(1),& & KRECVCOUNTS,IRECVDISPL_PT,INT(MPI_REAL4),ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL4)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_REAL4)) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLGATHERV',& & CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_REAL4 SUBROUTINE MPL_ALLGATHERV_REAL8(PSENDBUF,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE REAL(KIND=JPRD) :: PSENDBUF(:) REAL(KIND=JPRD) :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC INTEGER(KIND=JPIM) :: ITID,J INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS = .true. ! .TRUE. if KRECVCOUNTS is present (used in _int_scalar version) INTEGER(KIND=JPIM) :: IRECVCOUNTS(1) ! needed for _int_scalar version preamble ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = SIZE(PSENDBUF) ISENDCOUNT = MAX(0,ISENDCOUNT) ! Bug? on IBM ENDIF IRECVCOUNT = SIZE(PRECVBUF) !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !!--------- End of Preamble -------------- IERROR=0 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(PSENDBUF(1),ISENDCOUNT,INT(MPI_REAL8),PRECVBUF(1),& & KRECVCOUNTS,IRECVDISPL_PT,INT(MPI_REAL8),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(PSENDBUF(1),ISENDCOUNT,INT(MPI_REAL8),PRECVBUF(1),& & KRECVCOUNTS,IRECVDISPL_PT,INT(MPI_REAL8),ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_REAL8)) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLGATHERV',CDSTRING,& & LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_REAL8 SUBROUTINE MPL_ALLGATHERV_INT(KSENDBUF,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM) :: KSENDBUF(:) INTEGER(KIND=JPIM) :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS = .true. ! .TRUE. if KRECVCOUNTS is present (used in _int_scalar version) INTEGER(KIND=JPIM) :: IRECVCOUNTS(1) ! needed for _int_scalar version preamble ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = SIZE(KSENDBUF) ISENDCOUNT = MAX(0,ISENDCOUNT) ! Bug? on IBM ENDIF IRECVCOUNT = SIZE(KRECVBUF) !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !--------- End of Preamble -------------- IERROR=0 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(KSENDBUF(1),ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),& & KRECVCOUNTS,IRECVDISPL_PT,INT(MPI_INTEGER),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(KSENDBUF(1),ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),& & KRECVCOUNTS,IRECVDISPL_PT,INT(MPI_INTEGER),ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_INTEGER)) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLGATHERV',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_INT SUBROUTINE MPL_ALLGATHERV_INT_SCALAR(KSENDBUF,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_ALLGATHERV => MPI_ALLGATHERV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM) :: KSENDBUF INTEGER(KIND=JPIM) :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KRECVDISPL INTEGER(KIND=JPIM) :: IR,ISENDCOUNT,IRECVCOUNT INTEGER(KIND=JPIM) :: IMP_TYPE INTEGER(KIND=JPIM) :: IRECVCOUNTS(MPL_NUMPROC) INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: IRECVDISPL(:) INTEGER(KIND=JPIM), POINTER :: IRECVDISPL_PT(:) LOGICAL :: LKRECVCOUNTS ! .TRUE. if KRECVCOUNTS is present ITID = OML_MY_THREAD() IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT = KSENDCOUNT ELSE ISENDCOUNT = 1 ENDIF IRECVCOUNT = SIZE(KRECVBUF) IF(PRESENT(KRECVCOUNTS)) THEN IF(ANY(KRECVCOUNTS < 0) .OR. ANY(KRECVCOUNTS > 1)) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLGATHERV_INT_SCALAR: KRECVCOUNTS contains <0 or >1 counts',LDABORT=LLABORT) ENDIF IRECVCOUNTS=KRECVCOUNTS LKRECVCOUNTS = .TRUE. ELSE IRECVCOUNTS(:) = 1 LKRECVCOUNTS = .FALSE. ENDIF !--------- Preamble repeated for threadsafe-------------- #include "mpl_allgatherv_preamble.i90" !--------- End of Preamble -------------- IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLGATHERV(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),IRECVCOUNTS,& & IRECVDISPL_PT,INT(MPI_INTEGER),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLGATHERV(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),IRECVCOUNTS,& & IRECVDISPL_PT,INT(MPI_INTEGER),ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) CALL MPL_RECVSTATS(SUM(IRECVCOUNTS),INT(MPI_INTEGER)) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLGATHERV ',ISENDCOUNT,IRECVCOUNT,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLGATHERV',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_ALLGATHERV_INT_SCALAR END MODULE MPL_ALLGATHERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_close_mod.F900000664000175000017500000000552715157200431025320 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_CLOSE_MOD ! ! Purpose. close an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_close(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kfptr - handle for file pointer ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_CLOSE) ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO IMPLICIT NONE PRIVATE PUBLIC MPL_CLOSE CONTAINS SUBROUTINE MPL_CLOSE(KFPTR,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_CLOSE => MPI_FILE_CLOSE8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF ! ! ----------------------------------------------------------------- ! ! 1. Close the File ! -------------- CALL MPI_FILE_CLOSE(KFPTR,KERROR) ! ! ----------------------------------------------------------------- #else CALL ABOR1('MPI_CLOSE not built with MPI2') #endif ! RETURN END SUBROUTINE MPL_CLOSE END MODULE MPL_CLOSE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpi4to8_s.F900000664000175000017500000003664315157200431024335 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI4TO8_S #ifdef USE_8_BYTE_WORDS USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF IMPLICIT NONE PRIVATE :: STATUS8 INTEGER(KIND=8), DIMENSION(MPI_STATUS_SIZE) :: STATUS8 INTERFACE MPI_GET_COUNT8 MODULE PROCEDURE MPI_GET_COUNT8_I4, MPI_GET_COUNT8_I4_1 END INTERFACE MPI_GET_COUNT8 INTERFACE MPI_WAITALL8 MODULE PROCEDURE MPI_WAITALL8_I4, MPI_WAITALL8_I4_1 END INTERFACE MPI_WAITALL8 INTERFACE MPI_WAIT8 MODULE PROCEDURE MPI_WAIT8_I4, MPI_WAIT8_I4_1 END INTERFACE MPI_WAIT8 PUBLIC CONTAINS ! --------------------------------------------------------- SUBROUTINE MPI_ABORT8(COMM, ERRORCODE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, ERRORCODE INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COMM8, ERRORCODE8, IERROR8 COMM8 = COMM ERRORCODE8 = ERRORCODE CALL MPI_ABORT(COMM8, ERRORCODE8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_ABORT8 ! --------------------------------------------------------- SUBROUTINE MPI_BARRIER8(COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COMM8, IERROR8 COMM8 = COMM CALL MPI_BARRIER(COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BARRIER8 ! --------------------------------------------------------- SUBROUTINE MPI_BUFFER_DETACH8(BUFFER_ADDR, SZ, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & BUFFER_ADDR INTEGER(KIND=JPIM), INTENT(OUT) :: & SZ, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUFFER_ADDR8 INTEGER(KIND=8) :: & SZ8, IERROR8 ALLOCATE(BUFFER_ADDR8(SIZE(BUFFER_ADDR))) CALL MPI_BUFFER_DETACH(BUFFER_ADDR8, SZ8, IERROR8) BUFFER_ADDR = BUFFER_ADDR8 SZ = SZ8 IERROR = IERROR8 DEALLOCATE(BUFFER_ADDR8) END SUBROUTINE MPI_BUFFER_DETACH8 ! --------------------------------------------------------- SUBROUTINE MPI_BUFFER_ATTACH8(BUFFER_ADDR, SZ, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & BUFFER_ADDR INTEGER(KIND=JPIM), INTENT(IN) :: & SZ INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUFFER_ADDR8 INTEGER(KIND=8) :: & SZ8, IERROR8 ALLOCATE(BUFFER_ADDR8(SIZE(BUFFER_ADDR))) BUFFER_ADDR8 = BUFFER_ADDR SZ8 = SZ CALL MPI_BUFFER_ATTACH(BUFFER_ADDR8, SZ8, IERROR8) IERROR = IERROR8 DEALLOCATE(BUFFER_ADDR8) END SUBROUTINE MPI_BUFFER_ATTACH8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_COORDS8(COMM, RANK, MAXDIMS, COORDS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, RANK, MAXDIMS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: COORDS INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: COORDS8 INTEGER(KIND=8) :: & COMM8, RANK8, MAXDIMS8, IERROR8 ALLOCATE(COORDS8(SIZE(COORDS))) COMM8 = COMM RANK8 = RANK MAXDIMS8 = MAXDIMS CALL MPI_CART_COORDS(COMM8, RANK8, MAXDIMS8, COORDS8, IERROR8) COORDS = COORDS8 IERROR = IERROR8 DEALLOCATE(COORDS8) END SUBROUTINE MPI_CART_COORDS8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_CREATE8(COMM_OLD, NDIMS, DIMS, PERIODS, REORDER, COMM_CART, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM_OLD, NDIMS, DIMS(:) LOGICAL(KIND=JPIM), INTENT(IN) :: & PERIODS(:), REORDER INTEGER(KIND=JPIM), INTENT(OUT) :: & COMM_CART, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DIMS8 INTEGER(KIND=8) :: & COMM_OLD8, NDIMS8, COMM_CART8, IERROR8 LOGICAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & PERIODS8 LOGICAL(KIND=8) :: & REORDER8 ALLOCATE(DIMS8(SIZE(DIMS))) ALLOCATE(PERIODS8(SIZE(PERIODS))) COMM_OLD8 = COMM_OLD NDIMS8 = NDIMS DIMS8 = DIMS PERIODS8 = PERIODS REORDER8 = REORDER CALL MPI_CART_CREATE(COMM_OLD8, NDIMS8, DIMS8, PERIODS8, REORDER8, COMM_CART8, IERROR8) COMM_CART = COMM_CART8 IERROR = IERROR8 DEALLOCATE(DIMS8) DEALLOCATE(PERIODS8) END SUBROUTINE MPI_CART_CREATE8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_RANK8(COMM, COORDS, RANK, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(IN), DIMENSION(:) :: COORDS INTEGER(KIND=JPIM), INTENT(OUT) :: & RANK, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: COORDS8 INTEGER(KIND=8) :: & COMM8, RANK8, IERROR8 ALLOCATE(COORDS8(SIZE(COORDS))) COMM8 = COMM COORDS8 = COORDS CALL MPI_CART_RANK(COMM8, COORDS8, RANK8, IERROR8) RANK = RANK8 IERROR = IERROR8 DEALLOCATE(COORDS8) END SUBROUTINE MPI_CART_RANK8 ! --------------------------------------------------------- SUBROUTINE MPI_CART_SUB8(COMM, REMAIN_DIMS, NEWCOMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM LOGICAL(KIND=JPIM), INTENT(IN), DIMENSION(:) :: & REMAIN_DIMS INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWCOMM, IERROR INTEGER(KIND=8) :: & COMM8, NEWCOMM8, IERROR8 LOGICAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & REMAIN_DIMS8 ALLOCATE(REMAIN_DIMS8(SIZE(REMAIN_DIMS))) COMM8 = COMM REMAIN_DIMS8 = REMAIN_DIMS CALL MPI_CART_SUB(COMM8, REMAIN_DIMS8, NEWCOMM8, IERROR8) NEWCOMM = NEWCOMM8 IERROR = IERROR8 DEALLOCATE(REMAIN_DIMS8) END SUBROUTINE MPI_CART_SUB8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_CREATE8(COMM, GROUP, NEWCOMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, GROUP INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWCOMM, IERROR INTEGER(KIND=8) :: & COMM8, GROUP8, NEWCOMM8, IERROR8 COMM8 = COMM GROUP8 = GROUP CALL MPI_COMM_CREATE(COMM8, GROUP8, NEWCOMM8, IERROR8) NEWCOMM = NEWCOMM8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_CREATE8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_GROUP8(COMM, GROUP, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & GROUP, IERROR INTEGER(KIND=8) :: & COMM8, GROUP8, IERROR8 COMM8 = COMM CALL MPI_COMM_GROUP(COMM8, GROUP8, IERROR8) GROUP = GROUP8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_GROUP8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_RANK8(COMM, RANK, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RANK, IERROR INTEGER(KIND=8) :: & COMM8, RANK8, IERROR8 COMM8 = COMM CALL MPI_COMM_RANK(COMM8, RANK8, IERROR8) RANK = RANK8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_RANK8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_SIZE8(COMM, SIZE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & SIZE, IERROR INTEGER(KIND=8) :: & COMM8, SIZE8, IERROR8 COMM8 = COMM CALL MPI_COMM_SIZE(COMM8, SIZE8, IERROR8) SIZE = SIZE8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_SIZE8 ! --------------------------------------------------------- SUBROUTINE MPI_COMM_SPLIT8(COMM, COLOR, KEY, NEWCOMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, COLOR, KEY INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWCOMM, IERROR INTEGER(KIND=8) :: & COMM8, COLOR8, KEY8, NEWCOMM8, IERROR8 COMM8 = COMM COLOR8 = COLOR KEY8 = KEY CALL MPI_COMM_SPLIT(COMM8, COLOR8, KEY8, NEWCOMM8, IERROR8) NEWCOMM = NEWCOMM8 IERROR = IERROR8 END SUBROUTINE MPI_COMM_SPLIT8 ! --------------------------------------------------------- SUBROUTINE MPI_ERROR_STRING8(ERRORCODE, STRING, RESULTLEN, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & ERRORCODE CHARACTER(LEN=*), INTENT(OUT) :: & STRING INTEGER(KIND=JPIM), INTENT(OUT) :: & RESULTLEN, IERROR INTEGER(KIND=8) :: & ERRORCODE8, RESULTLEN8, IERROR8 ERRORCODE8 = ERRORCODE CALL MPI_ERROR_STRING(ERRORCODE8, STRING, RESULTLEN8, IERROR8) RESULTLEN = RESULTLEN8 IERROR = IERROR8 END SUBROUTINE MPI_ERROR_STRING8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_CLOSE8(FH, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, IERROR8 FH8 = FH CALL MPI_FILE_CLOSE(FH8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FILE_CLOSE8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_OPEN8(COMM, FILENAME, AMODE, INFO, FH, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COMM, AMODE, INFO CHARACTER(LEN=*), INTENT(IN) :: & FILENAME INTEGER(KIND=JPIM), INTENT(OUT) :: & FH, IERROR INTEGER(KIND=8) :: & COMM8, AMODE8, INFO8, FH8, IERROR8 COMM8 = COMM AMODE8 = AMODE INFO8 = INFO CALL MPI_FILE_OPEN(COMM8, FILENAME, AMODE8, INFO8, FH8, IERROR8) FH = FH8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_OPEN8 ! --------------------------------------------------------- SUBROUTINE MPI_FINALIZE8(IERROR) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & IERROR8 CALL MPI_FINALIZE(IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FINALIZE8 ! --------------------------------------------------------- SUBROUTINE MPI_GET_COUNT8_I4(STATUS, DATATYPE, COUNT, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & STATUS(:), DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & COUNT, IERROR INTEGER(KIND=8) :: & DATATYPE8, COUNT8, IERROR8 STATUS8 = STATUS DATATYPE8 = DATATYPE CALL MPI_GET_COUNT(STATUS8, DATATYPE8, COUNT8, IERROR8) COUNT = COUNT8 IERROR = IERROR8 END SUBROUTINE MPI_GET_COUNT8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_GET_COUNT8_I4_1(STATUS, DATATYPE, COUNT, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & STATUS, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & COUNT, IERROR INTEGER(KIND=8) :: & DATATYPE8, COUNT8, IERROR8, STATUS8 STATUS8 = STATUS DATATYPE8 = DATATYPE CALL MPI_GET_COUNT(STATUS8, DATATYPE8, COUNT8, IERROR8) COUNT = COUNT8 IERROR = IERROR8 END SUBROUTINE MPI_GET_COUNT8_I4_1 ! --------------------------------------------------------- SUBROUTINE MPI_GROUP_INCL8(GROUP1, N, RANKS, NEWGROUP, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & GROUP1, N, RANKS(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & NEWGROUP, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RANKS8 INTEGER(KIND=8) :: & GROUP18, N8, NEWGROUP8, IERROR8 ALLOCATE(RANKS8(SIZE(RANKS))) GROUP18 = GROUP1 N8 = N RANKS8 = RANKS CALL MPI_GROUP_INCL(GROUP18, N8, RANKS8, NEWGROUP8, IERROR8) NEWGROUP = NEWGROUP8 IERROR = IERROR8 DEALLOCATE(RANKS8) END SUBROUTINE MPI_GROUP_INCL8 ! --------------------------------------------------------- SUBROUTINE MPI_INIT8(IERROR) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & IERROR8 CALL MPI_INIT(IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_INIT8 ! --------------------------------------------------------- SUBROUTINE MPI_INITIALIZED8(FLAG, IERROR) INTEGER(KIND=JPIM), INTENT(OUT) :: & FLAG INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FLAG8 INTEGER(KIND=8) :: & IERROR8 CALL MPI_INITIALIZED(FLAG8, IERROR8) FLAG = FLAG8 IERROR = IERROR8 END SUBROUTINE MPI_INITIALIZED8 ! --------------------------------------------------------- SUBROUTINE MPI_IPROBE8(SOURCE, TAG, COMM, FLAG, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & FLAG INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & SOURCE8, TAG8, COMM8, IERROR8 INTEGER(KIND=8) :: & FLAG8 SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IPROBE(SOURCE8, TAG8, COMM8, FLAG8, STATUS8, IERROR8) FLAG = FLAG8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_IPROBE8 ! --------------------------------------------------------- SUBROUTINE MPI_PROBE8(SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & SOURCE8, TAG8, COMM8, IERROR8 SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_PROBE(SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_PROBE8 ! --------------------------------------------------------- SUBROUTINE MPI_WAIT8_I4(REQUEST, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(INOUT) :: & REQUEST INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & REQUEST8, IERROR8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: STATUS8 ALLOCATE(STATUS8(SIZE(STATUS))) REQUEST8 = REQUEST CALL MPI_WAIT(REQUEST8, STATUS8, IERROR8) REQUEST = REQUEST8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(STATUS8) END SUBROUTINE MPI_WAIT8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_WAIT8_I4_1(REQUEST, STATUS, IERROR) INTEGER(KIND=JPIM) :: & REQUEST INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS, IERROR INTEGER(KIND=8) :: & REQUEST8, IERROR8, STATUS8 REQUEST8 = REQUEST CALL MPI_WAIT(REQUEST8, STATUS8, IERROR8) REQUEST = REQUEST8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_WAIT8_I4_1 ! --------------------------------------------------------- SUBROUTINE MPI_WAITALL8_I4(COUNT, ARRAY_OF_REQUESTS, ARRAY_OF_STATUSES, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT INTEGER(KIND=JPIM), DIMENSION(:), INTENT(INOUT) :: & ARRAY_OF_REQUESTS INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & ARRAY_OF_STATUSES INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & ARRAY_OF_REQUESTS8 INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & ARRAY_OF_STATUSES8 INTEGER(KIND=8) :: & COUNT8, IERROR8 INTEGER :: N COUNT8 = COUNT ALLOCATE(ARRAY_OF_REQUESTS8(SIZE(ARRAY_OF_REQUESTS))) N = SIZE(ARRAY_OF_STATUSES) / MPI_STATUS_SIZE ALLOCATE(ARRAY_OF_STATUSES8(MPI_STATUS_SIZE,N)) ARRAY_OF_REQUESTS8 = ARRAY_OF_REQUESTS CALL MPI_WAITALL(COUNT8, ARRAY_OF_REQUESTS8, ARRAY_OF_STATUSES8, IERROR8) ARRAY_OF_REQUESTS = ARRAY_OF_REQUESTS8 ARRAY_OF_STATUSES = ARRAY_OF_STATUSES8 DEALLOCATE(ARRAY_OF_REQUESTS8) DEALLOCATE(ARRAY_OF_STATUSES8) IERROR = IERROR8 END SUBROUTINE MPI_WAITALL8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_WAITALL8_I4_1(COUNT, ARRAY_OF_REQUESTS, ARRAY_OF_STATUSES, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT INTEGER(KIND=JPIM) :: & ARRAY_OF_REQUESTS INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & ARRAY_OF_STATUSES INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & ARRAY_OF_REQUESTS8 INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & ARRAY_OF_STATUSES8 INTEGER(KIND=8) :: & COUNT8, IERROR8 INTEGER :: N COUNT8 = COUNT N = SIZE(ARRAY_OF_STATUSES) / MPI_STATUS_SIZE ALLOCATE(ARRAY_OF_STATUSES8(MPI_STATUS_SIZE,N)) ARRAY_OF_REQUESTS8 = ARRAY_OF_REQUESTS CALL MPI_WAITALL(COUNT8, ARRAY_OF_REQUESTS8, ARRAY_OF_STATUSES8, IERROR8) ARRAY_OF_REQUESTS = ARRAY_OF_REQUESTS8 ARRAY_OF_STATUSES = ARRAY_OF_STATUSES8 DEALLOCATE(ARRAY_OF_STATUSES8) IERROR = IERROR8 END SUBROUTINE MPI_WAITALL8_I4_1 #endif END MODULE MPI4TO8_S fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_comm_create_mod.F900000664000175000017500000000330215157200431026456 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_CREATE_MOD !**** MPL_COMM_CREATE Create a new communicator ! Purpose. ! -------- ! Create a new communicator and set as default !** Interface. ! ---------- ! CALL MPL_COMM_CREATE ! Input required arguments : ! ------------------------- ! Input optional arguments : ! ------------------------- ! Output required arguments : ! ------------------------- ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_COMM_CREATE aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_DATA_MODULE, ONLY : MPL_COMM, MPL_COMM_OML IMPLICIT NONE PRIVATE PUBLIC MPL_COMM_CREATE CONTAINS SUBROUTINE MPL_COMM_CREATE(KERROR) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() ! this line to be replaced MPL_COMM_OML(ITID)=MPL_COMM KERROR=0 RETURN END SUBROUTINE MPL_COMM_CREATE END MODULE MPL_COMM_CREATE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_gatherv_array_tmpl.i900000664000175000017500000000524715157200431027310 0ustar alastairalastairIF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT=KSENDCOUNT ELSE ISENDCOUNT = SIZE(PSENDBUF) ENDIF #ifndef NAGFOR IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1))) - LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= STORAGE_SIZE(PSENDBUF)/8*(ISENDCOUNT - 1) .AND. & & ISENDCOUNT > 0 ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. LLPRESENT_RECVBUF) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = SIZE(PRECVBUF) #ifndef NAGFOR IF( (LOC(PRECVBUF(UBOUND(PRECVBUF,1))) - LOC(PRECVBUF(LBOUND(PRECVBUF,1)))) /= STORAGE_SIZE(PRECVBUF)/8*(IRECVBUFSIZE - 1) .AND. & & IRECVBUFSIZE > 0 ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif ! need to ckeck if krecvcount is present, it is needed on root rank IF( .NOT. PRESENT(KRECVCOUNTS)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:KRECVCOUNTS MISSING ON ROOT RANK',CDSTRING=CDSTRING,LDABORT=LLABORT) CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & KRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF(1),ISENDCOUNT,IDATA_TYPE,PRECVBUF(1),KRECVCOUNTS, & & IRECVDISPL_PT,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF(1),ISENDCOUNT,IDATA_TYPE,PRECVBUF(1),KRECVCOUNTS, & & IRECVDISPL_PT,IDATA_TYPE,IROOT-1,ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,IDATA_TYPE) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),IDATA_TYPE) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF(1),ISENDCOUNT,IDATA_TYPE,ZDUM_JPRM,1, & & 1,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF(1),ISENDCOUNT,IDATA_TYPE,ZDUM_JPRM,1, & & 1,IDATA_TYPE,IROOT-1,ICOMM,KREQUEST,IERROR) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,IDATA_TYPE) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_GATHERV',& & CDSTRING,LDABORT=LLABORT) ENDIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_stats_mod.F900000664000175000017500000001664315157200431025352 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_STATS_MOD USE EC_PARKIND, ONLY : JPIM, JPRD USE YOMMPLSTATS, ONLY : LMPLSTATS, MPLRECVBYTES, MPLRECVNUM, MPLSENDBYTES, MPLSENDNUM PRIVATE PUBLIC :: MPL_STATSINIT, MPL_STATSON, MPL_STATSREAD, MPL_SENDSTATS, MPL_RECVSTATS CONTAINS SUBROUTINE MPL_STATSINIT !**** MPL_STATSINIT - Initialise collection of mpl statistics ! Purpose. ! -------- ! Initialises the mpl_stats package !** Interface. ! ---------- ! CALL MPL_STATSINIT ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) :: ITHR,OMP_GET_MAX_THREADS LMPLSTATS=.TRUE. ITHR = 1 !$ ITHR = OMP_GET_MAX_THREADS() ITHR = ITHR-1 ALLOCATE(MPLSENDBYTES(0:ITHR)) ALLOCATE(MPLRECVBYTES(0:ITHR)) ALLOCATE(MPLSENDNUM(0:ITHR)) ALLOCATE(MPLRECVNUM(0:ITHR)) MPLSENDBYTES(:) = 0 MPLRECVBYTES(:) = 0 MPLSENDNUM(:) = 0 MPLRECVNUM(:) = 0 RETURN END SUBROUTINE MPL_STATSINIT SUBROUTINE MPL_STATSON(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) !**** MPL_STATSON - Reset mpl statistics counters ! Purpose. ! -------- ! Returns the mpl statistics counter values ! and sets them back to zero ! non zero returned values correspond to messages that have ! been sent/received outside of a GSTATS MPL region !** Interface. ! ---------- ! CALL MPL_STATSON(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! SENDNUM - number of unknown messages sent ! SENDBYTES - number of unknown bytes sent ! RECVNUM - number of unknown messages received ! RECVBYTES - number of unknown bytes received ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE REAL(KIND=JPRD), INTENT(OUT) :: SENDBYTES,RECVBYTES INTEGER(KIND=JPIM), INTENT(OUT) :: SENDNUM,RECVNUM SENDBYTES = SUM(MPLSENDBYTES(:)) RECVBYTES = SUM(MPLRECVBYTES(:)) SENDNUM = SUM(MPLSENDNUM(:)) RECVNUM = SUM(MPLRECVNUM(:)) MPLSENDBYTES(:)=0.0_JPRD MPLRECVBYTES(:)=0.0_JPRD MPLSENDNUM(:)=0 MPLRECVNUM(:)=0 RETURN END SUBROUTINE MPL_STATSON SUBROUTINE MPL_STATSREAD(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) !**** MPL_STATSREAD - read mpl statistics counters ! Purpose. ! -------- ! returns the mpl statistics counter values ! before setting them back to zero !** Interface. ! ---------- ! CALL MPL_STATSREAD(SENDNUM,SENDBYTES,RECVNUM,RECVBYTES) ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! SENDNUM - number of messages sent ! SENDBYTES - number of bytes sent ! RECVNUM - number of messages received ! RECVBYTES - number of bytes received ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE REAL(KIND=JPRD), INTENT(OUT) :: SENDBYTES,RECVBYTES INTEGER(KIND=JPIM), INTENT(OUT) :: SENDNUM,RECVNUM SENDNUM=SUM(MPLSENDNUM(:)) RECVNUM=SUM(MPLRECVNUM(:)) SENDBYTES=SUM(MPLSENDBYTES(:)) RECVBYTES=SUM(MPLRECVBYTES (:)) MPLSENDNUM(:)=0 MPLRECVNUM(:)=0 MPLSENDBYTES(:)=0.0_JPRD MPLRECVBYTES(:)=0.0_JPRD RETURN END SUBROUTINE MPL_STATSREAD SUBROUTINE MPL_SENDSTATS(ICOUNT,ITYPE) !**** MPL_SENDSTATS - collect mpl send statistics ! Purpose. ! -------- ! counts the number of messages and volume sent !** Interface. ! ---------- ! CALL MPL_SENDSTATS(ICOUNT,ITYPE) ! Input required arguments : ! ------------------------- ! ICOUNT - The number of elements sent ! ITYPE - The type of an element ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: ICOUNT INTEGER(KIND=JPIM),INTENT(IN) :: ITYPE INTEGER(KIND=JPIM) ISIZE,IERR,ITH,OMP_GET_THREAD_NUM ITH = 0 !$ ITH = OMP_GET_THREAD_NUM() MPLSENDNUM(ITH) = MPLSENDNUM(ITH) + 1 CALL MPI_TYPE_SIZE(ITYPE,ISIZE,IERR) MPLSENDBYTES(ITH)=MPLSENDBYTES(ITH) + FLOAT(ISIZE * ICOUNT) RETURN END SUBROUTINE MPL_SENDSTATS SUBROUTINE MPL_RECVSTATS(ICOUNT,ITYPE) !**** MPL_RECVSTATS - collect mpl recv statistics ! Purpose. ! -------- ! counts the number of messages and volume received !** Interface. ! ---------- ! CALL MPL_RECVSTATS(ICOUNT,ITYPE) ! Input required arguments : ! ------------------------- ! ICOUNT - The number of elements received ! ITYPE - The type of an element ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! P.Towers ECMWF ! Modifications. ! -------------- ! Original: 2011-04-06 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: ICOUNT INTEGER(KIND=JPIM),INTENT(IN) :: ITYPE INTEGER(KIND=JPIM) ISIZE,IERR,ITH,OMP_GET_THREAD_NUM ITH = 0 !$ ITH = OMP_GET_THREAD_NUM() MPLRECVNUM(ITH) = MPLRECVNUM(ITH) + 1 CALL MPI_TYPE_SIZE(ITYPE,ISIZE,IERR) MPLRECVBYTES(ITH)=MPLRECVBYTES(ITH) + FLOAT(ISIZE * ICOUNT) RETURN END SUBROUTINE MPL_RECVSTATS END MODULE MPL_STATS_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_waitany_mod.F900000664000175000017500000000617715157200431025671 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_WAITANY_MOD !**** MPL_WAITANY Waits for completion of any request ! Purpose. ! -------- ! Returns control when any operation identified by the request ! is completed. ! Normally used in conjunction with non-blocking buffering type !** Interface. ! ---------- ! CALL MPL_WAITANY ! Input required arguments : ! ------------------------- ! KREQUEST - array or scalar containing ! Communication request(s) ! as provided by MPL_RECV or MPL_SEND ! Input optional arguments : ! ------------------------- ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! KINDEX - index of received request ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_WAITANY aborts when an error is detected. ! Author. ! ------- ! R. El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original: 02-Sep-2014 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRM, JPIB USE MPL_MPIF, ONLY : MPI_STATUS_SIZE, MPI_UNDEFINED USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_WAITANY CONTAINS SUBROUTINE MPL_WAITANY(KREQUEST,KINDEX,CDSTRING,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITANY => MPI_WAITANY8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KREQUEST(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KINDEX CHARACTER(LEN=*) ,INTENT(IN), OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM) :: IWAITERR,IREQLEN,J INTEGER(KIND=JPIM) :: IWAIT_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT LLABORT=.TRUE. IWAITERR=0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAITANY: MPL NOT INITIALISED ',LDABORT=LLABORT) KINDEX = MPI_UNDEFINED IREQLEN=SIZE(KREQUEST) #ifndef MPI1 CALL MPI_WAITANY(IREQLEN,KREQUEST,KINDEX,IWAIT_STATUS,IWAITERR) #else !CALL ABOR1('MPI_WAITANY not built with MPI2') IWAITERR = MPI_ERR_UNKNOWN ! Initialized in case all requests already NULL (= logic err in code) DO J=1,IREQLEN IF (KREQUEST(J) /= MPI_REQUEST_NULL) THEN CALL MPI_WAIT(KREQUEST(J),IWAIT_STATUS,IWAITERR) KINDEX = J EXIT ENDIF ENDDO #endif IF(PRESENT(KERROR))THEN KERROR=IWAITERR ELSE IF(IWAITERR /= 0) THEN CALL MPL_MESSAGE(IWAITERR,'MPL_WAITANY_WAITING',CDSTRING,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_WAITANY END MODULE MPL_WAITANY_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_recv_mod.F900000664000175000017500000010335615157200431025151 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_RECV_MOD !**** MPL_RECV Receive a message ! Purpose. ! -------- ! Receive a message from a named source into a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or REAL or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_RECV ! Input required arguments : ! ------------------------- ! PBUF - buffer to receive the message ! (can be type REAL*4, REAL*8 or INTEGER) ! Input optional arguments : ! ------------------------- ! KTAG - message tag ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KSOURCE - rank of process sending the message ! default is MPI_ANY_SOURCE ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KFROM - rank of process sending the message ! KRECVTAG - tag of received message ! KOUNT - number of items in received message ! KERROR - return error code. If not supplied, ! MPL_RECV aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIB, JPIM, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_BYTE, MPI_INTEGER, MPI_INTEGER8, MPI_REAL4, MPI_REAL8, & & MPI_STATUS_SIZE, MPI_ANY_SOURCE, MPI_SOURCE, MPI_ANY_TAG, MPI_TAG USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_ERRUNIT, MPL_NUMPROC, MPL_METHOD, & & JP_BLOCKING_BUFFERED, JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_NPROC_MOD, ONLY : MPL_NPROC IMPLICIT NONE PRIVATE INTERFACE MPL_RECV MODULE PROCEDURE MPL_RECV_REAL4, MPL_RECV_REAL8, & & MPL_RECV_INT, MPL_RECV_REAL42, MPL_RECV_REAL43, & & MPL_RECV_REAL82, MPL_RECV_REAL83, MPL_RECV_INT_SCALAR, & & MPL_RECV_INT2, MPL_RECV_REAL4_SCALAR, & & MPL_RECV_REAL8_SCALAR, MPL_RECV_CHAR_SCALAR, & & MPL_RECV_INT8, MPL_RECV_CHAR END INTERFACE PUBLIC MPL_RECV CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_PREAMB(KMP_TYPER,KCOMMR,KSOURCER,KTAGR,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) INTEGER(KIND=JPIM),INTENT(OUT) :: KMP_TYPER,KCOMMR,KSOURCER,KTAGR INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KMP_TYPE,KCOMM,KSOURCE,KTAG INTEGER(KIND=JPIM),OPTIONAL :: KREQUEST LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_RECV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN KMP_TYPER=KMP_TYPE ELSE KMP_TYPER=MPL_METHOD ENDIF IF(KMP_TYPER == JP_NON_BLOCKING_STANDARD) THEN IF( .NOT. PRESENT(KREQUEST)) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:KREQUEST MISSING ',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KCOMM)) THEN KCOMMR=KCOMM ELSE KCOMMR=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KSOURCE)) THEN IF(KSOURCE < 1 .OR. KSOURCE >MPL_NPROC(KCOMMR)) THEN WRITE(MPL_ERRUNIT,*)'MPL_RECV: ERROR KSOURCE=',KSOURCE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL KSOURCE ',LDABORT=LLABORT) ENDIF KSOURCER=KSOURCE-1 ELSE KSOURCER=MPI_ANY_SOURCE ENDIF IF(PRESENT(KTAG)) THEN KTAGR=KTAG ELSE KTAGR=MPI_ANY_TAG ENDIF END SUBROUTINE MPL_RECV_PREAMB ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_TAIL(KRECV_STATUS,KTYPE,KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_GET_COUNT => MPI_GET_COUNT8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KRECV_STATUS(MPI_STATUS_SIZE) INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: IFROM,IRECVTAG,IRECVCOUNT LOGICAL :: LLABORT=.TRUE. IFROM=KRECV_STATUS(MPI_SOURCE)+1 IF(PRESENT(KFROM)) THEN KFROM=IFROM ENDIF CALL MPI_GET_COUNT(KRECV_STATUS,KTYPE,IRECVCOUNT,IERROR) IF(PRESENT(KOUNT)) THEN KOUNT=IRECVCOUNT ENDIF IF(LMPLSTATS) CALL MPL_RECVSTATS(IRECVCOUNT,KTYPE) IRECVTAG=KRECV_STATUS(MPI_TAG) IF(PRESENT(KRECVTAG)) THEN KRECVTAG=IRECVTAG ENDIF !IF(MPL_OUTPUT > 1 )THEN ! WRITE(MPL_UNIT,'(A,5I8)') ' MPL_RECV ',IRECVCOUNT,IMP_TYPE,IFROM,IRECVTAG,ICOMM !ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_RECV',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_RECV_TAIL ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL4(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1))) - LOC(PBUF(LBOUND(PBUF,1)))) /= 4_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM(1),1,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF(1),IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF(1),IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF(1),IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL4),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL4)) ENDIF END SUBROUTINE MPL_RECV_REAL4 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL8(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif ! real_b,intent(in) :: PBUF(:) REAL(KIND=JPRD) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1))) - LOC(PBUF(LBOUND(PBUF,1)))) /= 8_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM(1),1,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF(1),IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF(1),IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF(1),IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL8),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL8)) ENDIF END SUBROUTINE MPL_RECV_REAL8 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_INT(KBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,KOUNT,& &KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIM) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID,IDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(KBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1)))-LOC(KBUF(LBOUND(KBUF,1)))) /= 4_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(IDUM(1),1,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(IDUM(1),1,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(IDUM(1),1,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KBUF(1),IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KBUF(1),IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KBUF(1),IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_INTEGER),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_INTEGER)) ENDIF END SUBROUTINE MPL_RECV_INT SUBROUTINE MPL_RECV_INT8(KBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,KOUNT,& &KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIB) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIB) :: IDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(KBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1)))-LOC(KBUF(LBOUND(KBUF,1)))) /= 8_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0 ) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(IDUM(1),1,INT(MPI_INTEGER8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(IDUM(1),1,INT(MPI_INTEGER8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(IDUM(1),1,INT(MPI_INTEGER8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KBUF(1),IBUFFSIZE,INT(MPI_INTEGER8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KBUF(1),IBUFFSIZE,INT(MPI_INTEGER8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KBUF(1),IBUFFSIZE,INT(MPI_INTEGER8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_INTEGER8),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_INTEGER8)) ENDIF END SUBROUTINE MPL_RECV_INT8 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_INT2(KBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIM) :: KBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID, IDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(KBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1),UBOUND(KBUF,2))) - & & LOC(KBUF(LBOUND(KBUF,1),LBOUND(KBUF,2)))) /= 4_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0 ) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(IDUM(1),1,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(IDUM(1),1,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(IDUM(1),1,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KBUF(1,1),IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KBUF(1,1),IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KBUF(1,1),IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_INTEGER),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_INTEGER)) ENDIF END SUBROUTINE MPL_RECV_INT2 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_INT_SCALAR(KINT,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif INTEGER(KIND=JPIM) :: KINT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(KINT,IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(KINT,IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(KINT,IBUFFSIZE,INT(MPI_INTEGER),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_INTEGER),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_INTEGER)) ENDIF END SUBROUTINE MPL_RECV_INT_SCALAR ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL4_SCALAR(PREAL4,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PREAL4 INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PREAL4,IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PREAL4,IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PREAL4,IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL4),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL4)) ENDIF END SUBROUTINE MPL_RECV_REAL4_SCALAR ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL8_SCALAR(PREAL8,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRD) :: PREAL8 INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PREAL8,IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PREAL8,IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PREAL8,IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL8),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL8)) ENDIF END SUBROUTINE MPL_RECV_REAL8_SCALAR ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL42(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2)))) /= 4_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM(1),1,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF(1,1),IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF(1,1),IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF(1,1),IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL4),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL4)) ENDIF END SUBROUTINE MPL_RECV_REAL42 SUBROUTINE MPL_RECV_REAL43(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRM) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3)))) /= 4_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,INT(MPI_REAL4),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL4),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL4)) ENDIF END SUBROUTINE MPL_RECV_REAL43 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_REAL82(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRD) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1) ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2)))) /= 8_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IBUFFSIZE == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(ZDUM(1),1,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(ZDUM(1),1,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF(1,1),IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF(1,1),IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF(1,1),IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL8),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL8)) ENDIF END SUBROUTINE MPL_RECV_REAL82 SUBROUTINE MPL_RECV_REAL83(PBUF,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif REAL(KIND=JPRD) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = SIZE(PBUF) #ifndef NAGFOR IF (IBUFFSIZE > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3)))) /= 8_JPIB*(IBUFFSIZE - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(PBUF,IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(PBUF,IBUFFSIZE,INT(MPI_REAL8),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_REAL8),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_REAL8)) ENDIF END SUBROUTINE MPL_RECV_REAL83 ! ------------------------------------------------------------------ SUBROUTINE MPL_RECV_CHAR_SCALAR(CDCHAR,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif CHARACTER(LEN=*) :: CDCHAR INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = LEN(CDCHAR) IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,INT(MPI_BYTE),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,INT(MPI_BYTE),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(CDCHAR,IBUFFSIZE,INT(MPI_BYTE),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_BYTE),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_BYTE)) ENDIF END SUBROUTINE MPL_RECV_CHAR_SCALAR SUBROUTINE MPL_RECV_CHAR(CDCHAR,KSOURCE,KTAG,KCOMM,KFROM,KRECVTAG,& &KOUNT,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_RECV => MPI_RECV8, MPI_IRECV => MPI_IRECV8 #endif CHARACTER(LEN=*) :: CDCHAR(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KTAG,KCOMM,KMP_TYPE,KSOURCE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR,KFROM,KRECVTAG,KOUNT CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IBUFFSIZE,IMP_TYPE,ICOMM,IERROR INTEGER(KIND=JPIM) :: ISOURCE,ITAG INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() CALL MPL_RECV_PREAMB(IMP_TYPE,ICOMM,ISOURCE,ITAG,KMP_TYPE,KCOMM,KSOURCE,KTAG,KREQUEST) IBUFFSIZE = LEN(CDCHAR) * SIZE(CDCHAR) IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,INT(MPI_BYTE),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_RECV(CDCHAR,IBUFFSIZE,INT(MPI_BYTE),ISOURCE,ITAG,ICOMM,IRECV_STATUS,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_IRECV(CDCHAR,IBUFFSIZE,INT(MPI_BYTE),ISOURCE,ITAG,ICOMM, & & KREQUEST,IERROR) ELSE CALL MPL_MESSAGE(CDMESSAGE='MPL_RECV:ILLEGAL MP_TYPE ',LDABORT=LLABORT) ENDIF IF(IMP_TYPE /= JP_NON_BLOCKING_STANDARD) THEN CALL MPL_RECV_TAIL(IRECV_STATUS,INT(MPI_BYTE),KFROM,KOUNT,KRECVTAG,KERROR,CDSTRING) ELSE IF(LMPLSTATS) CALL MPL_RECVSTATS(IBUFFSIZE,INT(MPI_BYTE)) ENDIF END SUBROUTINE MPL_RECV_CHAR ! ------------------------------------------------------------------ END MODULE MPL_RECV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_displs_container_mod.F900000664000175000017500000002253515157200431027551 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. MODULE MPL_DISPLS_CONTAINER_MOD !**** MPL_DISPLS_CONTAINER_MOD - Container for the displacements arrays ! Purpose. ! -------- ! This module provides a container for the displacements arrays ! used in the non-blocking collectives when they are not provided by the caller routine. ! !** Interface. ! ---------- ! CALL YDDISPLS%APPEND(REQ, NPROC, SEND_PT, RECV_PT, NO_NEW_NODE) ! Input optional arguments : ! ------------------------- ! REQ - Request ID ! NPROC - Number of processes in communicator ! NO_NEW_NODE - If present, the new node is not created, the current node is updated ! Output optional arguments : ! ------------------------- ! RECV_PT - Pointer to the recv displacements array ! SEND_PT - Pointer to the send displacements array !** Interface. ! ---------- ! CALL YDDISPLS%REMOVE_REQ(REQ) ! Input required arguments : ! ------------------------- ! REQ - Request ID whose associate node to be removed !** Interface. ! ---------- ! CALL YDDISPLS%TEST_REQ() ! Author. ! ------- ! L. Anton ! Modifications. ! -------------- ! Original: 2025-04-01 USE EC_PARKIND, ONLY : JPIM USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_DATA_MODULE, ONLY : MPL_ERRUNIT, MPL_RANK IMPLICIT NONE PRIVATE TYPE, PRIVATE :: DISPLACEMENTS INTEGER(KIND=JPIM) :: REQ INTEGER(KIND=JPIM) :: NPROC = 0 INTEGER(KIND=JPIM), ALLOCATABLE :: SEND(:) INTEGER(KIND=JPIM), ALLOCATABLE :: RECV(:) TYPE(DISPLACEMENTS), POINTER :: PREV CONTAINS PROCEDURE :: INITIALIZE PROCEDURE :: GET_SEND PROCEDURE :: GET_RECV PROCEDURE :: GET_REQ PROCEDURE :: GET_NPROC END TYPE DISPLACEMENTS TYPE, PUBLIC :: LIST_MANAGER TYPE(DISPLACEMENTS), POINTER :: HEAD => NULL() INTEGER :: LIST_SIZE = 0 CONTAINS PROCEDURE :: APPEND PROCEDURE :: REMOVE_FIRST PROCEDURE :: REMOVE_REQ1 PROCEDURE :: REMOVE_REQS PROCEDURE :: CLEAR_LIST PROCEDURE :: PRINT_LIST GENERIC :: REMOVE_REQ => REMOVE_REQ1, REMOVE_REQS END TYPE LIST_MANAGER LOGICAL :: LLABORT = .TRUE. INTEGER, PARAMETER :: ITEST_SIZE = 20! ! Drop a warning if the linked list size exceeds this value ! It is not expected to have a large number of active displacements in the list TYPE(LIST_MANAGER),PUBLIC,TARGET :: YDDISPLS_LIST ! the only instance of the list manager CONTAINS SUBROUTINE INITIALIZE(THIS, KREQ, KNPROC, KSEND_PT, KRECV_PT) CLASS(DISPLACEMENTS), TARGET, INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KREQ, KNPROC INTEGER(KIND=JPIM), POINTER, INTENT(OUT), OPTIONAL :: KSEND_PT(:), KRECV_PT(:) IF ( PRESENT(KREQ)) THEN THIS%REQ = KREQ END IF IF (PRESENT(KNPROC)) THEN IF ( THIS%NPROC == 0 ) THEN THIS%NPROC = KNPROC ELSE IF ( KNPROC /= THIS%NPROC) THEN CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & Trying to update nproc > 0',& & LDABORT=LLABORT) END IF END IF END IF IF (PRESENT(KSEND_PT)) THEN IF (THIS%NPROC > 0 ) THEN ALLOCATE(THIS%SEND(THIS%NPROC)) KSEND_PT => THIS%SEND ELSE CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & Trying to allocate send displs but nproc == 0',& & LDABORT=LLABORT) END IF END IF IF (PRESENT(KRECV_PT)) THEN IF (THIS%NPROC > 0 ) THEN ALLOCATE(THIS%RECV(THIS%NPROC)) KRECV_PT => THIS%RECV ELSE CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & Trying to allocate recv displs but nproc == 0',& & LDABORT=LLABORT) END IF END IF THIS%PREV => NULL() END SUBROUTINE INITIALIZE FUNCTION GET_SEND(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), ALLOCATABLE :: R(:) R = THIS%SEND END FUNCTION GET_SEND FUNCTION GET_RECV(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), ALLOCATABLE :: R(:) R = THIS%RECV END FUNCTION GET_RECV FUNCTION GET_REQ(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM) R R = THIS%REQ END FUNCTION GET_REQ FUNCTION GET_NPROC(THIS) RESULT(R) IMPLICIT NONE CLASS(DISPLACEMENTS), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM) R R = THIS%NPROC END FUNCTION GET_NPROC SUBROUTINE APPEND(THIS, KREQ, KNPROC, KSEND_PT, KRECV_PT, NO_NEW_NODE) CLASS(LIST_MANAGER), TARGET, INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KREQ, KNPROC INTEGER(KIND=JPIM), POINTER, INTENT(OUT), OPTIONAL :: KSEND_PT(:), KRECV_PT(:) LOGICAL, INTENT(IN), OPTIONAL :: NO_NEW_NODE TYPE(DISPLACEMENTS), POINTER :: YLNEW_NODE, YLTMP LOGICAL :: LLNEW_NODE IF(PRESENT(NO_NEW_NODE)) THEN LLNEW_NODE = .NOT. NO_NEW_NODE ELSE LLNEW_NODE = .TRUE. ENDIF IF (.NOT. ASSOCIATED(THIS%HEAD)) THEN IF (.NOT. LLNEW_NODE) THEN CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_DISPLS_CONTAINER_MOD:& & APPEND called with NO_NEW_NODE=.TRUE.& & but the internal linked list is empty',& & LDABORT=LLABORT) END IF ALLOCATE(YLNEW_NODE) CALL YLNEW_NODE%INITIALIZE(KREQ,KNPROC,KSEND_PT,KRECV_PT) THIS%HEAD => YLNEW_NODE THIS%LIST_SIZE = THIS%LIST_SIZE + 1 ELSE IF (LLNEW_NODE) THEN ALLOCATE(YLNEW_NODE) CALL YLNEW_NODE%INITIALIZE(KREQ,KNPROC,KSEND_PT,KRECV_PT) YLNEW_NODE%PREV => THIS%HEAD THIS%HEAD => YLNEW_NODE THIS%LIST_SIZE = THIS%LIST_SIZE + 1 ELSE ! Update the curent head YLTMP => THIS%HEAD%PREV ! initialise sets prev to NULL CALL THIS%HEAD%INITIALIZE(KREQ,KNPROC,KSEND_PT,KRECV_PT) THIS%HEAD%PREV => YLTMP END IF END IF IF (THIS%LIST_SIZE > ITEST_SIZE) THEN WRITE(MPL_ERRUNIT,*) 'WARNING: rank ', MPL_RANK, 'The displacements list size ', & & THIS%LIST_SIZE, ' > ', ITEST_SIZE END IF END SUBROUTINE APPEND SUBROUTINE REMOVE_FIRST(THIS) CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS TYPE(DISPLACEMENTS), POINTER :: TMP IF (.NOT. ASSOCIATED(THIS%HEAD)) RETURN TMP => THIS%HEAD THIS%HEAD => THIS%HEAD%PREV DEALLOCATE(TMP) THIS%LIST_SIZE = THIS%LIST_SIZE - 1 END SUBROUTINE REMOVE_FIRST SUBROUTINE REMOVE_REQ1(THIS,KREQ) IMPLICIT NONE CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS INTEGER, INTENT(IN) :: KREQ TYPE(DISPLACEMENTS), POINTER :: YLCURRENT, YLCURRENT_, YLTMP YLCURRENT => THIS%HEAD DO WHILE (ASSOCIATED(YLCURRENT)) IF (YLCURRENT%REQ == KREQ) THEN IF ( ASSOCIATED(THIS%HEAD, YLCURRENT) ) THEN YLTMP => THIS%HEAD THIS%HEAD => THIS%HEAD%PREV YLCURRENT => THIS%HEAD ELSE YLTMP => YLCURRENT YLCURRENT => YLCURRENT%PREV YLCURRENT_%PREV => YLCURRENT END IF DEALLOCATE(YLTMP) THIS%LIST_SIZE = THIS%LIST_SIZE - 1 EXIT ELSE YLCURRENT_ => YLCURRENT YLCURRENT => YLCURRENT%PREV END IF ENDDO END SUBROUTINE REMOVE_REQ1 SUBROUTINE REMOVE_REQS(THIS,KREQ) IMPLICIT NONE CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS INTEGER(KIND=JPIM), INTENT(IN) :: KREQ(:) INTEGER(KIND=JPIM), PARAMETER :: IMAX_WARNINGS = 10 INTEGER(KIND=JPIM), SAVE :: IWARNING = 0 TYPE(DISPLACEMENTS), POINTER :: CURRENT, CURRENT_, TMP INTEGER(KIND=JPIM) :: I LOGICAL :: LLFOUND IF (THIS%LIST_SIZE == 0) RETURN ! This subroutine could be expensive if the requests array is large ! This could happen if non-blocking collectives request are mixed ! point to point non-blocking requests ! The application programmer should avoid this by using different ! call to mpl_wait for the different types of requests IF (IWARNING < IMAX_WARNINGS) THEN IF (SIZE(KREQ) > MAX(INT(0.1 * THIS%HEAD%NPROC), 10)) THEN WRITE(MPL_ERRUNIT,*) 'WARNING: rank ', MPL_RANK, 'REMOVE_REQ called with a request array of size ', & & SIZE(KREQ) IWARNING = IWARNING + 1 ENDIF ENDIF CURRENT => THIS%HEAD DO WHILE (ASSOCIATED(CURRENT)) LLFOUND = .FALSE. ! this loop order will pass unnecessarly over the removed requests ! but it does not scan the list multiple times DO I=1,SIZE(KREQ) IF (KREQ(I) == CURRENT%REQ) THEN IF ( ASSOCIATED(THIS%HEAD, CURRENT) ) THEN TMP => THIS%HEAD THIS%HEAD => THIS%HEAD%PREV CURRENT => THIS%HEAD ELSE CURRENT_%PREV => CURRENT%PREV TMP => CURRENT CURRENT => CURRENT%PREV END IF LLFOUND = .TRUE. DEALLOCATE(TMP) THIS%LIST_SIZE = THIS%LIST_SIZE - 1 EXIT END IF END DO IF (.NOT. LLFOUND) THEN CURRENT_ => CURRENT CURRENT => CURRENT%PREV END IF ENDDO END SUBROUTINE REMOVE_REQS SUBROUTINE CLEAR_LIST(THIS) CLASS(LIST_MANAGER), INTENT(INOUT) :: THIS DO WHILE(ASSOCIATED(THIS%HEAD)) CALL THIS%REMOVE_FIRST() END DO END SUBROUTINE CLEAR_LIST SUBROUTINE PRINT_LIST(THIS) CLASS(LIST_MANAGER), INTENT(IN) :: THIS TYPE(DISPLACEMENTS), POINTER :: CURRENT CURRENT => THIS%HEAD WRITE(*,*)'-----------------' WRITE(*,*) 'Rank', MPL_RANK, 'List size ', THIS%LIST_SIZE DO WHILE(ASSOCIATED(CURRENT)) WRITE(*,*) 'REQUEST ', CURRENT%REQ IF (ALLOCATED(CURRENT%SEND)) WRITE(*,*) 'SEND DISPLS', CURRENT%SEND IF (ALLOCATED(CURRENT%RECV)) WRITE(*,*) 'RECV DISPLS', CURRENT%RECV CURRENT => CURRENT%PREV END DO WRITE(*,*)'-----------------' END SUBROUTINE PRINT_LIST END MODULE MPL_DISPLS_CONTAINER_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_bytes_mod.F900000664000175000017500000000261615157200431025335 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BYTES_MOD USE EC_PARKIND, ONLY : JPIM, JPIB, JPRM, JPRD IMPLICIT NONE PRIVATE PUBLIC :: MPL_BYTES INTERFACE MPL_BYTES MODULE PROCEDURE & & MPL_BYTES_IM, MPL_BYTES_IB, & & MPL_BYTES_RM, MPL_BYTES_RD END INTERFACE MPL_BYTES CONTAINS ! INTEGER*4 FUNCTION MPL_BYTES_IM(KVAR) INTEGER(KIND=JPIM), INTENT(IN) :: KVAR INTEGER(KIND=JPIM) MPL_BYTES_IM MPL_BYTES_IM = SIZE(TRANSFER(KVAR, (/'A'/))) END FUNCTION MPL_BYTES_IM ! INTEGER*8 FUNCTION MPL_BYTES_IB(KVAR) INTEGER(KIND=JPIB), INTENT(IN) :: KVAR INTEGER(KIND=JPIM) MPL_BYTES_IB MPL_BYTES_IB = SIZE(TRANSFER(KVAR, (/'A'/))) END FUNCTION MPL_BYTES_IB ! REAL*4 FUNCTION MPL_BYTES_RM(PVAR) REAL(KIND=JPRM), INTENT(IN) :: PVAR INTEGER(KIND=JPIM) MPL_BYTES_RM MPL_BYTES_RM = SIZE(TRANSFER(PVAR, (/'A'/))) END FUNCTION MPL_BYTES_RM ! REAL*8 FUNCTION MPL_BYTES_RD(PVAR) REAL(KIND=JPRD), INTENT(IN) :: PVAR INTEGER(KIND=JPIM) MPL_BYTES_RD MPL_BYTES_RD = SIZE(TRANSFER(PVAR, (/'A'/))) END FUNCTION MPL_BYTES_RD END MODULE MPL_BYTES_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_wait_mod.F900000664000175000017500000001416415157200431025154 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_WAIT_MOD !**** MPL_WAIT Waits for completion ! Purpose. ! -------- ! Returns control when the operation(s) identified by the request ! is completed. ! Normally used in conjunction with non-blocking buffering type !** Interface. ! ---------- ! CALL MPL_WAIT ! Input required arguments : ! ------------------------- ! KREQUEST - array or scalar containing ! Communication request(s) ! as provided by MPL_RECV or MPL_SEND ! Input optional arguments : ! ------------------------- ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KOUNT - must be the same size and shape as KREQUEST ! contains number of items sent/received ! KBYTES - number of bytes in a single element in all KOUNTs ! *must* be supplied with KOUNT ! KBYTES normally determited robustly by MPL_BYTES ! KERROR - return error code. If not supplied, ! MPL_WAIT aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! J. Hague: 2005-04-25 WAITALL replaced by WAIT loop ! F. Vana 05-Mar-2015 Support for single precision ! S. Saarinen 17-Feb-2017 Removed PBUF argument (not realy needed) ! KREQUEST must be INOUT (as per MPI_Wait) ! MPL_WAITS calls MPI_Waitall unless MPI1 ! S. Saarinen 01-Mar-2017 Added KBYTES ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM, JPRM, JPIB USE MPL_MPIF, ONLY : MPI_BYTE, MPI_STATUS_SIZE USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE INTERFACE MPL_WAIT MODULE PROCEDURE MPL_WAITS, MPL_WAIT1 END INTERFACE PUBLIC MPL_WAIT CONTAINS SUBROUTINE MPL_WAITS(KREQUEST,KOUNT,KBYTES,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITALL => MPI_WAITALL8, MPI_GET_COUNT => MPI_GET_COUNT8, & MPI_WAIT => MPI_WAIT8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KREQUEST(:) CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KOUNT(SIZE(KREQUEST)) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM) :: IWAITERR,ICOUNTERR,JL,IREQLEN,ICOUNT,IW INTEGER(KIND=JPIM) :: IWAIT_STATUS(MPI_STATUS_SIZE,SIZE(KREQUEST)) INTEGER(KIND=JPIM) :: IREQUEST(SIZE(KREQUEST)) LOGICAL :: LLABORT LLABORT=.TRUE. IWAITERR=0 ICOUNTERR=0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAITS: MPL NOT INITIALISED ',LDABORT=LLABORT) IREQLEN=SIZE(KREQUEST) IREQUEST(:) = KREQUEST(:) #ifndef MPI1 CALL MPI_WAITALL(IREQLEN,KREQUEST,IWAIT_STATUS,IWAITERR) #else DO JL=1,IREQLEN CALL MPI_WAIT(KREQUEST(JL),IWAIT_STATUS(1,JL),IW) IWAITERR=MAX(IWAITERR,IW) ENDDO #endif IF(PRESENT(KOUNT))THEN IF (.not.PRESENT(KBYTES)) THEN CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: KBYTES MUST BE PRESENT WITH KOUNT ', & & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF IF(SIZE(KOUNT) /= IREQLEN) THEN CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: KOUNT AND KREQUEST INCONSISTENT ', & & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF DO JL=1,IREQLEN CALL MPI_GET_COUNT(IWAIT_STATUS(1,JL),INT(MPI_BYTE),KOUNT(JL),ICOUNTERR) KOUNT(JL) = KOUNT(JL) / KBYTES ENDDO ENDIF IF(PRESENT(KERROR))THEN KERROR=IWAITERR+ICOUNTERR ELSE IF(IWAITERR /= 0) THEN CALL MPL_MESSAGE(IWAITERR,'MPL_WAITS_WAITING',CDSTRING,LDABORT=LLABORT) ELSE IF(ICOUNTERR /= 0) THEN CALL MPL_MESSAGE(ICOUNTERR,'MPL_WAITS_COUNT',CDSTRING,LDABORT=LLABORT) ENDIF ! DELETE THE NON-BLOCKING COLLECTIVES DISPLACEMENTS ARRAYS CALL YDDISPLS_LIST%REMOVE_REQ(IREQUEST) RETURN END SUBROUTINE MPL_WAITS SUBROUTINE MPL_WAIT1(KREQUEST,KOUNT,KBYTES,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_WAITALL => MPI_WAITALL8, MPI_GET_COUNT => MPI_GET_COUNT8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM) :: IWAITERR,ICOUNTERR,JL,IREQLEN,ICOUNT INTEGER(KIND=JPIM) :: IWAIT_STATUS(MPI_STATUS_SIZE) INTEGER(KIND=JPIM) :: IREQUEST LOGICAL :: LLABORT LLABORT=.TRUE. IWAITERR=0 ICOUNTERR=0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: MPL NOT INITIALISED ',LDABORT=LLABORT) IREQUEST=KREQUEST CALL MPI_WAIT(KREQUEST,IWAIT_STATUS,IWAITERR) ! DELETE THE NON-BLOCKING COLLECTIVES DISPLACEMENTS ARRAYS, IF THE WAIT IS ON THEM CALL YDDISPLS_LIST%REMOVE_REQ(IREQUEST) IF(PRESENT(KOUNT))THEN IF (.not.PRESENT(KBYTES)) THEN CALL MPL_MESSAGE( & & CDMESSAGE='MPL_WAIT: KBYTES MUST BE PRESENT WITH KOUNT ', & & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF CALL MPI_GET_COUNT(IWAIT_STATUS(1),INT(MPI_BYTE),KOUNT,ICOUNTERR) KOUNT = KOUNT / KBYTES ENDIF IF(PRESENT(KERROR))THEN KERROR=IWAITERR+ICOUNTERR ELSE IF(IWAITERR /= 0) THEN CALL MPL_MESSAGE(IWAITERR,'MPL_WAIT_WAITING',CDSTRING,LDABORT=LLABORT) ELSE IF(ICOUNTERR /= 0) THEN CALL MPL_MESSAGE(ICOUNTERR,'MPL_WAIT_COUNT',CDSTRING,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_WAIT1 END MODULE MPL_WAIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_read_mod.F900000664000175000017500000002006615157200431025121 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_READ_MOD ! ! Purpose. read from an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_read(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kfptr - handle for file ! kop - requested operation ! kbuf - buffer containing data to be written ! klen - length of buffer in words ! input/output arguements: ! kreq - request handle for non-blocking operations ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-11 ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND ,ONLY : JPIM, JPRM USE MPL_MPIF, ONLY : MPI_STATUS_SIZE, MPI_INTEGER, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO, MPL_IOP IMPLICIT NONE INTERFACE MPL_READ MODULE PROCEDURE MPL_READ_INT,MPL_READ_REAL8 END INTERFACE PRIVATE PUBLIC MPL_READ CONTAINS SUBROUTINE MPL_READ_INT(KFPTR,KOP,KBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_READ_SHARED => MPI_FILE_READ_SHARED8, & MPI_FILE_READ_ORDERED => MPI_FILE_READ_ORDERED8, & MPI_FILE_IREAD_SHARED => MPI_FILE_IREAD_SHARED8, & MPI_FILE_READ_ORDERED_BEGIN => MPI_FILE_READ_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, MPI_FILE_READ_ORDERED_END => MPI_FILE_READ_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) KBUF(:) INTEGER(KIND=JPIM) KREQ INTEGER(KIND=JPIM) STATUS(MPI_STATUS_SIZE) ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking read, non collective, shared file pointer CALL MPI_FILE_READ_SHARED(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking read, non collective, shared file pointer CALL MPI_FILE_IREAD_SHARED(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED_BEGIN(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_READ_ORDERED_END(KFPTR,& & KBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF #else CALL ABOR1('MPL_READ_INT not build with MPI2') #endif ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_READ_INT SUBROUTINE MPL_READ_REAL8(KFPTR,KOP,PBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_READ_SHARED => MPI_FILE_READ_SHARED8, & MPI_FILE_READ_ORDERED => MPI_FILE_READ_ORDERED8, & MPI_FILE_IREAD_SHARED => MPI_FILE_IREAD_SHARED8, & MPI_FILE_READ_ORDERED_BEGIN => MPI_FILE_READ_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, MPI_FILE_READ_ORDERED_END => MPI_FILE_READ_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR REAL(KIND=JPRM) PBUF(:) INTEGER(KIND=JPIM) KREQ INTEGER(KIND=JPIM) STATUS(MPI_STATUS_SIZE) ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking read, non collective, shared file pointer CALL MPI_FILE_READ_SHARED(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking read, non collective, shared file pointer CALL MPI_FILE_IREAD_SHARED(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking read, collective, ordered with shared file pointer CALL MPI_FILE_READ_ORDERED_BEGIN(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_READ_ORDERED_END(KFPTR,& & PBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF ! ! ----------------------------------------------------------------- #else CALL ABOR1('MPL_READ_REAL8 not build with MPI2') #endif RETURN END SUBROUTINE MPL_READ_REAL8 END MODULE MPL_READ_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_broadcast_mod.F900000664000175000017500000011301315157200431026143 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BROADCAST_MOD !**** MPL_BROADCAST Message broadcast ! Purpose. ! -------- ! Broadcasts a message from the process with rank root ! to all processes in the group. !** Interface. ! ---------- ! CALL MPL_BROADCAST ! Input required arguments : ! ------------------------- ! PBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KTAG - message tag ! Input optional arguments : ! ------------------------- ! KROOT - number of root process (default=1) ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_BROADCAST aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud, S.Saarinen ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P.Marguinaud : 2012-04-13 : Cleaning & refactor PREAMB1 ! P.Marguinaud : 2012-09-11 : Add MPL_BROADCAST_LOGICAL1 ! M.Hamrud : 2014-10-22 : Add nonblocking option ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_REAL4, MPI_REAL8, MPI_INTEGER, MPI_INTEGER8, MPI_BYTE, MPI_LOGICAL USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_COMM_OML, MPL_RANK, MPL_METHOD, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_MYRANK_MOD, ONLY : MPL_MYRANK IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_BROADCAST MODULE PROCEDURE MPL_BROADCAST_REAL4,MPL_BROADCAST_REAL8, & & MPL_BROADCAST_REAL42,MPL_BROADCAST_REAL43,MPL_BROADCAST_REAL44,& & MPL_BROADCAST_REAL82,MPL_BROADCAST_REAL83,MPL_BROADCAST_REAL84,& & MPL_BROADCAST_REAL4_SCALAR,MPL_BROADCAST_REAL8_SCALAR, & & MPL_BROADCAST_INT,MPL_BROADCAST_INT2,MPL_BROADCAST_INT3,MPL_BROADCAST_INT_SCALAR, & & MPL_BROADCAST_LONG, & & MPL_BROADCAST_CHAR_SCALAR, MPL_BROADCAST_CHAR1, & & MPL_BROADCAST_LOGICAL_SCALAR, MPL_BROADCAST_LOGICAL1 END INTERFACE PUBLIC MPL_BROADCAST CONTAINS SUBROUTINE MPL_BROADCAST_PREAMB1(KROOTR,KCOMMR,KPL_NUMPROC,KPL_MYRANK,KMP_TYPER,LDRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(OUT) :: KROOTR INTEGER(KIND=JPIM),INTENT(OUT) :: KCOMMR INTEGER(KIND=JPIM),INTENT(OUT) :: KPL_NUMPROC INTEGER(KIND=JPIM),INTENT(OUT) :: KPL_MYRANK INTEGER(KIND=JPIM),INTENT(OUT) :: KMP_TYPER LOGICAL, INTENT(OUT) :: LDRETURN INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KMP_TYPE INTEGER(KIND=JPIM) :: IERROR INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IERROR = 0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_BROADCAST: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN KCOMMR=KCOMM ELSE KCOMMR=MPL_COMM_OML(ITID) ENDIF IF(KCOMMR == MPL_COMM_OML(ITID)) THEN KPL_NUMPROC = MPL_NUMPROC KPL_MYRANK = MPL_RANK ELSE CALL MPI_COMM_SIZE(KCOMMR,KPL_NUMPROC,IERROR) KPL_MYRANK = MPL_MYRANK(KCOMMR) ENDIF IF(PRESENT(KROOT)) THEN KROOTR=KROOT ELSE KROOTR=1 ENDIF IF(PRESENT(KMP_TYPE)) THEN KMP_TYPER=KMP_TYPE ELSE KMP_TYPER=MPL_METHOD ENDIF IF (PRESENT (KERROR)) KERROR = IERROR IF (KPL_NUMPROC == 1) THEN IF(PRESENT(KERROR)) THEN KERROR=0 ENDIF LDRETURN=.TRUE. ELSE LDRETURN=.FALSE. ENDIF END SUBROUTINE MPL_BROADCAST_PREAMB1 SUBROUTINE MPL_BROADCAST_REAL4(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRM) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL4 SUBROUTINE MPL_BROADCAST_REAL8(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) ! Passing PBUF(1) here causes incorrect results on IBM IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL8 SUBROUTINE MPL_BROADCAST_REAL42(PBUF,KTAG,KROOT,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) REAL(KIND=JPRM) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF(1,1),ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF(1,1),ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL42 SUBROUTINE MPL_BROADCAST_REAL43(PBUF,KTAG,KROOT,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) REAL(KIND=JPRM) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF(1,1,1),ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF(1,1,1),ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL43 SUBROUTINE MPL_BROADCAST_REAL44(PBUF,KTAG,KROOT,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) REAL(KIND=JPRM) :: PBUF(:,:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3),UBOUND(PBUF,4))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3),LBOUND(PBUF,4)))) & & /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF(1,1,1,1),ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF(1,1,1,1),ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL44 SUBROUTINE MPL_BROADCAST_REAL82(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF(1,1),ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF(1,1),ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL82 SUBROUTINE MPL_BROADCAST_REAL83(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF(1,1,1),ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF(1,1,1),ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL83 SUBROUTINE MPL_BROADCAST_REAL84(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF(:,:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3),UBOUND(PBUF,4))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3),LBOUND(PBUF,4)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF(1,1,1,1),ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF(1,1,1,1),ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL84 SUBROUTINE MPL_BROADCAST_REAL4_SCALAR(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRM) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,INT(MPI_REAL4),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL4_SCALAR SUBROUTINE MPL_BROADCAST_REAL8_SCALAR(PBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif REAL(KIND=JPRD) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(PBUF,ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(PBUF,ICOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_REAL8_SCALAR SUBROUTINE MPL_BROADCAST_LONG(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIB) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,INT(MPI_INTEGER8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,INT(MPI_INTEGER8),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_LONG SUBROUTINE MPL_BROADCAST_INT(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIM) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT SUBROUTINE MPL_BROADCAST_INT2(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) INTEGER(KIND=JPIM) :: KBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1),UBOUND(KBUF,2))) - & & LOC(KBUF(LBOUND(KBUF,1),LBOUND(KBUF,2)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT2 SUBROUTINE MPL_BROADCAST_INT3(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) INTEGER(KIND=JPIM) :: KBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE(KBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1),UBOUND(KBUF,2),UBOUND(KBUF,3))) - & & LOC(KBUF(LBOUND(KBUF,1),LBOUND(KBUF,2),LBOUND(KBUF,3)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BROADCAST: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF(1,1,1),ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(KBUF(1,1,1),ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT3 SUBROUTINE MPL_BROADCAST_INT_SCALAR(KBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIM) :: KBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(KBUF,ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(KBUF,ICOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_INT_SCALAR SUBROUTINE MPL_BROADCAST_CHAR_SCALAR(CDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif CHARACTER(LEN=*) :: CDBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = LEN(CDBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(CDBUF,ICOUNT,INT(MPI_BYTE),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(CDBUF,ICOUNT,INT(MPI_BYTE),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_CHAR_SCALAR SUBROUTINE MPL_BROADCAST_CHAR1(CDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif CHARACTER(LEN=*) :: CDBUF (:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = LEN(CDBUF)*SIZE(CDBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(CDBUF,ICOUNT,INT(MPI_BYTE),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(CDBUF,ICOUNT,INT(MPI_BYTE),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_CHAR1 SUBROUTINE MPL_BROADCAST_LOGICAL_SCALAR(LDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif LOGICAL :: LDBUF INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = 1 IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST(LDBUF,ICOUNT,INT(MPI_LOGICAL),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST(LDBUF,ICOUNT,INT(MPI_LOGICAL),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_LOGICAL_SCALAR SUBROUTINE MPL_BROADCAST_LOGICAL1(LDBUF,KTAG,KROOT,KMP_TYPE,& KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_BCAST => MPI_BCAST8 #endif LOGICAL :: LDBUF (:) INTEGER(KIND=JPIM),INTENT(IN) :: KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,ICOMM,IERROR,IROOT,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE LOGICAL :: LLRETURN CALL MPL_BROADCAST_PREAMB1(IROOT,ICOMM,IPL_NUMPROC,IPL_MYRANK,IMP_TYPE,LLRETURN,KERROR,KCOMM,KROOT,KMP_TYPE) IF (LLRETURN) RETURN IERROR = 0 ICOUNT = SIZE (LDBUF) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BCAST (LDBUF,ICOUNT,INT(MPI_LOGICAL),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_SEND',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IBCAST (LDBUF,ICOUNT,INT(MPI_LOGICAL),IROOT-1,ICOMM,KREQUEST,IERROR) ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_BROADCAST',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(LMPLSTATS) THEN IF(IROOT == IPL_MYRANK) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF CALL MPL_RECVSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BROADCAST',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_BROADCAST_LOGICAL1 END MODULE MPL_BROADCAST_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_nproc_mod.F900000664000175000017500000000302315157200431025321 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_NPROC_MOD !**** MPL_NPROC - return Number of processes ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_NPROC CONTAINS FUNCTION MPL_NPROC(KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM) :: MPL_NPROC INTEGER(KIND=JPIM) :: IERROR,IPROC LOGICAL :: LLABORT=.TRUE. IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_MYRANK: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN CALL MPI_COMM_SIZE(KCOMM,IPROC,IERROR) MPL_NPROC = IPROC ELSE MPL_NPROC = MPL_NUMPROC ENDIF END FUNCTION MPL_NPROC END MODULE MPL_NPROC_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_comm_split_mod.F900000664000175000017500000000236315157200431026354 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_COMM_SPLIT_MOD !**** *MPL_COMM_SPLIT* - Split a communicator ! Author. ! ------- ! Philippe Marguinaud *METEO FRANCE* ! Original : 11-09-2012 USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_UNDEFINED IMPLICIT NONE PRIVATE PUBLIC MPL_COMM_SPLIT CONTAINS SUBROUTINE MPL_COMM_SPLIT (KCOMM, KCOLOR, KKEY, KNEWCOMM, KERROR, CDSTRING) INTEGER (KIND=JPIM), INTENT (IN) :: KCOMM INTEGER (KIND=JPIM), INTENT (IN) :: KCOLOR INTEGER (KIND=JPIM), INTENT (IN) :: KKEY INTEGER (KIND=JPIM), INTENT (OUT) :: KNEWCOMM INTEGER (KIND=JPIM), INTENT (OUT) :: KERROR CHARACTER (LEN=*), OPTIONAL, INTENT (IN) :: CDSTRING INTEGER (KIND=JPIM) :: ICOLOR ICOLOR=KCOLOR IF(ICOLOR<0) ICOLOR=MPI_UNDEFINED CALL MPI_COMM_SPLIT (KCOMM, ICOLOR, KKEY, KNEWCOMM, KERROR) END SUBROUTINE MPL_COMM_SPLIT END MODULE MPL_COMM_SPLIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_mygatherv_mod.F900000664000175000017500000000257015157200431026214 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MYGATHERV_MOD USE EC_PARKIND, ONLY : JPRD, JPIM USE MPL_MPIF, ONLY : MPI_REAL8 USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_MYGATHERV LOGICAL :: LLABORT=.TRUE. CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_MYGATHERV(PSEND,KSEND,PRECV,KRECV,KDISPL,KROOT,KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif REAL(KIND=JPRD), INTENT(IN) :: PSEND(:) REAL(KIND=JPRD), INTENT(OUT) :: PRECV(:) INTEGER(KIND=JPIM), INTENT(IN) :: KSEND, KRECV(:), KDISPL(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT, KCOMM INTEGER(KIND=JPIM) :: IERR CALL MPI_GATHERV(PSEND,KSEND,INT(MPI_REAL8), & & PRECV,KRECV,KDISPL,INT(MPI_REAL8),KROOT-1,KCOMM,IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_MYGATHERV',LDABORT=LLABORT) END SUBROUTINE MPL_MYGATHERV ! ------------------------------------------------------------------ END MODULE MPL_MYGATHERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_myrank_mod.F900000664000175000017500000000417415157200431025511 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MYRANK_MOD !**** MPL_MYRANK - Find rank ! Purpose. ! -------- ! Returns the rank of the calling process ! in the currently active communicator !** Interface. ! ---------- ! IRANK=MPL_MYRANK(KCOMM) ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! Input required arguments : ! ------------------------- ! Input optional arguments : ! ------------------------- ! none ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! none ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_RANK USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_MYRANK CONTAINS FUNCTION MPL_MYRANK(KCOMM) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_RANK => MPI_COMM_RANK8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM) :: MPL_MYRANK INTEGER(KIND=JPIM) IRANK,IERROR,ICOMM LOGICAL :: LLABORT=.TRUE. IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_MYRANK: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN CALL MPI_COMM_RANK(KCOMM, IRANK, IERROR) IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,& &'MPL_MYRANK: ERROR FROM MPI_COMM_RANK') MPL_MYRANK=IRANK+1 ELSE MPL_MYRANK=MPL_RANK ENDIF END FUNCTION MPL_MYRANK END MODULE MPL_MYRANK_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_gatherv_mod.F900000664000175000017500000005444115157200431025652 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_GATHERV_MOD !**** MPL_GATHERV Gather data to specific processor ! Purpose. ! -------- ! Gather data to specific processor ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_GATHERV ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PRECVBUF - buffer containing message (required from kroot) ! (can be type REAL*4, REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! (required from kroot processor) ! Input optional arguments : ! ------------------------- ! KROOT - rank of receiveing processor (default 1) ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_GATHERV aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-11-23 ! M.Hamrud: 2014-10-22 : Add nonblocking option ! F.Vana: 2015-03-05 : Support for single precision ! P.Gillies: 2018-06-25 : Add SENDCOUNT argument, needed for zero-length sends ! --- *NOT* THREAD SAFE YET --- ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_CHARACTER, MPI_INTEGER, MPI_REAL4, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_ERRUNIT, MPL_METHOD, MPL_NUMPROC, MPL_RANK, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_MYRANK_MOD, ONLY : MPL_MYRANK USE MPL_WAIT_MOD, ONLY : MPL_WAIT USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. REAL(KIND=JPRD) :: ZDUM_JPRD REAL(KIND=JPRM) :: ZDUM_JPRM INTEGER(KIND=JPIM) :: ZDUM_INT INTERFACE MPL_GATHERV MODULE PROCEDURE MPL_GATHERV_REAL8,MPL_GATHERV_REAL4,MPL_GATHERV_CHAR_SCALAR,& & MPL_GATHERV_INT,MPL_GATHERV_INT_SCALAR END INTERFACE PUBLIC MPL_GATHERV CONTAINS SUBROUTINE MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE, & & KCOMM,KROOT,KMP_TYPE,KREQUEST) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(OUT) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE,KREQUEST INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IERROR = 0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_GATHERV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(ICOMM == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC IPL_MYRANK = MPL_RANK ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) IPL_MYRANK = MPL_MYRANK(ICOMM) ENDIF IF(PRESENT(KROOT)) THEN IROOT=KROOT ELSE IROOT=1 ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: KREQUEST MISSING',LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_PREAMB1 SUBROUTINE MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & KRECVCOUNTS,KIRECVDISPL,KIRECVDISPL_PT,IMP_TYPE,KRECVDISPL,KREQUEST,CDSTRING) INTEGER(KIND=JPIM),INTENT(IN) :: IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),ALLOCATABLE,TARGET,INTENT(OUT) :: KIRECVDISPL(:) INTEGER(KIND=JPIM), POINTER, INTENT(OUT) :: KIRECVDISPL_PT(:) INTEGER(KIND=JPIM),INTENT(IN) :: IMP_TYPE INTEGER(KIND=JPIM),INTENT(IN),TARGET,OPTIONAL :: KRECVDISPL(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IR IF(SIZE(KRECVCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_GATHERV: ERROR KRECVCOUNTS DIMENSION=',& & SIZE(KRECVCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_GATHERV: ERROR KRECVCOUNTS DIMENSION IS WRONG',LDABORT=LLABORT) ENDIF IF(ISENDCOUNT /= KRECVCOUNTS(IPL_MYRANK)) THEN WRITE(MPL_ERRUNIT,*)'MPL_GATHERV: ERROR KRECVCOUNTS INCONSISTENCY ',& & ISENDCOUNT,KRECVCOUNTS(IPL_MYRANK) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_GATHERV: ERROR ISENDCOUNT /= KRECVCOUNTS(MPL_RANK) ',LDABORT=LLABORT) ENDIF IF(PRESENT(KRECVDISPL)) THEN KIRECVDISPL_PT => KRECVDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC, KRECV_PT=KIRECVDISPL_PT) ELSE ALLOCATE(KIRECVDISPL(IPL_NUMPROC)) KIRECVDISPL_PT => KIRECVDISPL END IF KIRECVDISPL_PT(1) = 0 DO IR=2, IPL_NUMPROC KIRECVDISPL_PT(IR) = KIRECVDISPL_PT(IR-1) + KRECVCOUNTS(IR-1) ENDDO ENDIF DO IR=1, IPL_NUMPROC IF(KIRECVDISPL_PT(IR)+KRECVCOUNTS(IR) > IRECVBUFSIZE) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_GATHERV:RECV BUFFER TOO SMALL ', & & IR,KIRECVDISPL_PT(IR),KRECVCOUNTS(IR),IRECVBUFSIZE CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV',CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF ENDDO END SUBROUTINE MPL_GATHERV_PREAMB2 SUBROUTINE MPL_GATHERV_REAL4(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif REAL(KIND=JPRM),INTENT(IN) :: PSENDBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT REAL(KIND=JPRM),INTENT(OUT),OPTIONAL :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT,IDATA_TYPE LOGICAL LLPRESENT_RECVBUF IDATA_TYPE=INT(MPI_REAL4) LLPRESENT_RECVBUF=PRESENT(PRECVBUF) #include "mpl_gatherv_array_tmpl.i90" END SUBROUTINE MPL_GATHERV_REAL4 SUBROUTINE MPL_GATHERV_REAL8(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif REAL(KIND=JPRD) :: PSENDBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT REAL(KIND=JPRD),OPTIONAL :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT INTEGER(KIND=JPIM) :: IDUM,IST,IEND,JK, IDATA_TYPE LOGICAL :: LLPRESENT_RECVBUF IDATA_TYPE = INT(MPI_REAL8) LLPRESENT_RECVBUF=PRESENT(PRECVBUF) #include "mpl_gatherv_array_tmpl.i90" END SUBROUTINE MPL_GATHERV_REAL8 SUBROUTINE MPL_GATHERV_INT(KSENDBUF,KROOT,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT INTEGER(KIND=JPIM),TARGET,INTENT(IN) :: KSENDBUF(:) INTEGER(KIND=JPIM),TARGET,INTENT(OUT),OPTIONAL :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KSENDCOUNT,KCOMM,KMP_TYPE INTEGER(KIND=JPIM),TARGET,INTENT(IN),OPTIONAL :: KRECVDISPL(:) INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT,IDATA_TYPE LOGICAL LLPRESENT_RECVBUF IDATA_TYPE=INT(MPI_INTEGER) LLPRESENT_RECVBUF=PRESENT(KRECVBUF) IF (PRESENT(KRECVBUF)) THEN ASSOCIATE(PSENDBUF=>KSENDBUF,PRECVBUF=>KRECVBUF) #include "mpl_gatherv_array_tmpl.i90" END ASSOCIATE ELSE ASSOCIATE(PSENDBUF=>KSENDBUF,PRECVBUF=>KSENDBUF) #include "mpl_gatherv_array_tmpl.i90" END ASSOCIATE END IF END SUBROUTINE MPL_GATHERV_INT SUBROUTINE MPL_GATHERV_CHAR_SCALAR(CSENDBUF,KROOT,CRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, & & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8 #endif CHARACTER(LEN=*) :: CSENDBUF INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT CHARACTER(LEN=*),OPTIONAL :: CRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT INTEGER(KIND=JPIM) :: IDUM,IST,IEND,JK !,ICOUNT IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT=KSENDCOUNT ELSE ISENDCOUNT = LEN(CSENDBUF) ENDIF CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. PRESENT(CRECVBUF)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = LEN(CRECVBUF)*SIZE(CRECVBUF) #ifndef NAGFOR IF( (LOC(CRECVBUF(UBOUND(CRECVBUF,1))) - LOC(CRECVBUF(LBOUND(CRECVBUF,1)))) /= (IRECVBUFSIZE-LEN(CRECVBUF) ) .AND. & & IRECVBUFSIZE > 0 ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF #endif CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & KRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),CRECVBUF(1),KRECVCOUNTS,& & IRECVDISPL_PT,INT(MPI_CHARACTER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),CRECVBUF(1),KRECVCOUNTS,& & IRECVDISPL_PT,INT(MPI_CHARACTER),IROOT-1,ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_CHARACTER)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_CHARACTER)) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),ZDUM_JPRD,1, & & 1,INT(MPI_CHARACTER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),ZDUM_JPRD,1, & & 1,INT(MPI_CHARACTER),IROOT-1,ICOMM,KREQUEST,IERROR) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_CHARACTER)) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_GATHERV',CDSTRING,& & LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_CHAR_SCALAR SUBROUTINE MPL_GATHERV_INT_SCALAR(KSENDBUF,KROOT,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,& & KMP_TYPE,KRECVDISPL,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8, MPI_GATHER => MPI_GATHER8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KSENDBUF INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IRECVCOUNTS(MPL_NUMPROC) INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT IF(PRESENT(KSENDCOUNT)) THEN ISENDCOUNT=KSENDCOUNT ELSE ISENDCOUNT = 1 ENDIF IF(PRESENT(KRECVCOUNTS)) THEN IRECVCOUNTS=KRECVCOUNTS ELSE IRECVCOUNTS(:) = 1 ENDIF CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. PRESENT(KRECVBUF)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = SIZE(KRECVBUF) IF(PRESENT(KRECVDISPL).OR.PRESENT(KSENDCOUNT)) THEN IF(.NOT.PRESENT(KSENDCOUNT)) THEN IRECVCOUNTS(:) = 1 ENDIF CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & IRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),& & IRECVCOUNTS,IRECVDISPL_PT,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),& & IRECVCOUNTS,IRECVDISPL_PT,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) CALL MPL_RECVSTATS(SUM(IRECVCOUNTS),INT(MPI_INTEGER)) ENDIF ELSE IF(IRECVBUFSIZE < IPL_NUMPROC) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV:IRECVBUFSIZE < IPL_NUMPROC',& & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),& & ISENDCOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),KRECVBUF(1),& & ISENDCOUNT,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_INTEGER)) ENDIF ENDIF ELSE IF(PRESENT(KRECVDISPL).OR.PRESENT(KSENDCOUNT)) THEN IF(.NOT.PRESENT(KSENDCOUNT)) THEN IRECVCOUNTS(:)=1 ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),ZDUM_INT,KRECVBUF(1), & & IRECVCOUNTS,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),ZDUM_INT,1, & & 1,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),ZDUM_INT,& & 1,INT(MPI_INTEGER),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(KSENDBUF,ISENDCOUNT,INT(MPI_INTEGER),ZDUM_INT,& & 1,INT(MPI_INTEGER),IROOT-1,ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) ENDIF ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_GATHERV',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_INT_SCALAR SUBROUTINE MPL_GATHERV_REAL8_SCALAR(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,& & KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_GATHERV => MPI_GATHERV8, MPI_GATHER => MPI_GATHER8 #endif REAL(KIND=JPRD),INTENT(IN) :: PSENDBUF INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT REAL(KIND=JPRD),INTENT(OUT),OPTIONAL :: PRECVBUF(:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:) ! Not used; for compatibility only INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: IRECVCOUNTS(MPL_NUMPROC) INTEGER(KIND=JPIM),ALLOCATABLE :: IRECVDISPL(:) INTEGER(KIND=JPIM),POINTER :: IRECVDISPL_PT(:) INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT ISENDCOUNT = 1 CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. PRESENT(PRECVBUF)) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT) IRECVBUFSIZE = SIZE(PRECVBUF) IF(PRESENT(KRECVDISPL)) THEN IRECVCOUNTS(:) = 1 CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,& & IRECVCOUNTS,IRECVDISPL,IRECVDISPL_PT,IMP_TYPE,KRECVDISPL,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),PRECVBUF(1),& & IRECVCOUNTS,IRECVDISPL_PT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),PRECVBUF(1),& & IRECVCOUNTS,IRECVDISPL_PT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) CALL MPL_RECVSTATS(SUM(IRECVCOUNTS),INT(MPI_REAL8)) ENDIF ELSE IF(IRECVBUFSIZE < IPL_NUMPROC) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV:IRECVBUFSIZE < IPL_NUMPROC',& & CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),PRECVBUF(1),& & ISENDCOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),PRECVBUF(1),& & ISENDCOUNT,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_REAL8)) ENDIF ENDIF ELSE IF(PRESENT(KRECVDISPL)) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHERV(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),ZDUM_JPRD,1, & & 1,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHERV(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),ZDUM_JPRD,1, & & 1,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_GATHER(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),ZDUM_JPRD,& & 1,INT(MPI_REAL8),IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IGATHER(PSENDBUF,ISENDCOUNT,INT(MPI_REAL8),ZDUM_JPRD,& & 1,INT(MPI_REAL8),IROOT-1,ICOMM,KREQUEST,IERROR) CALL MPL_WAIT(KREQUEST) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) ENDIF ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_GATHERV',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_GATHERV_REAL8_SCALAR END MODULE MPL_GATHERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_groups.F900000664000175000017500000000732315157200431024667 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_GROUPS ! Purpose. ! -------- ! Use MPI groups for easier to read code (and more efficient ! communications, at least on IBM). ! Author. ! ------- ! Y. Tremolet ! Modifications. ! -------------- ! Original: 02-03-13 ! ------------------------------------------------------------------ ! --- *NOT* THREAD SAFE YET --- USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_COMM_GRID, MPL_ALL_LEVS_COMM, MPL_ALL_MS_COMM, & & MPL_GROUPS_CREATE, MPL_CART_RANK, MPL_CART_COORDS INTEGER(KIND=JPIM) :: MPL_COMM_GRID, MPL_ALL_LEVS_COMM, MPL_ALL_MS_COMM, & & MPL_GP_GRID LOGICAL,SAVE :: LGROUPSETUP=.FALSE. CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_GROUPS_CREATE(KPROCW, KPROCV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_CART_CREATE => MPI_CART_CREATE8, MPI_COMM_GROUP => MPI_COMM_GROUP8, & MPI_CART_SUB => MPI_CART_SUB8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KPROCW, KPROCV INTEGER(KIND=JPIM) :: IDIMS(2), IERR LOGICAL :: LTORUS(2), LDIMS(2), LREORDER IF(LGROUPSETUP) RETURN IDIMS(1)=KPROCW IDIMS(2)=KPROCV LTORUS(1)=.FALSE. LTORUS(2)=.FALSE. LREORDER=.FALSE. CALL MPI_CART_CREATE(MPL_COMM_OML(1), 2, IDIMS, LTORUS, LREORDER, & & MPL_COMM_GRID, IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_GROUPS_CREATE: MPI_CART_CREATE') CALL MPI_COMM_GROUP(MPL_COMM_GRID, MPL_GP_GRID, IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_GROUPS_CREATE: mpi_comm_group') ! Group all levels for same Ms ! ---------------------------- LDIMS(1)=.FALSE. LDIMS(2)=.TRUE. CALL MPI_CART_SUB(MPL_COMM_GRID, LDIMS, MPL_ALL_LEVS_COMM, IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_GROUPS_CREATE: mpi_cart_sub 1') ! Group all Ms for same levels ! ---------------------------- LDIMS(1)=.TRUE. LDIMS(2)=.FALSE. CALL MPI_CART_SUB(MPL_COMM_GRID, LDIMS, MPL_ALL_MS_COMM, IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_GROUPS_CREATE: mpi_cart_sub 2') LGROUPSETUP=.TRUE. END SUBROUTINE MPL_GROUPS_CREATE ! ------------------------------------------------------------------ FUNCTION MPL_CART_RANK(KPROCW, KPROCV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_CART_RANK => MPI_CART_RANK8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KPROCW, KPROCV INTEGER(KIND=JPIM) :: MPL_CART_RANK INTEGER(KIND=JPIM) :: IDIMS(2), IPROC, IERR IDIMS(1)=KPROCW-1 IDIMS(2)=KPROCV-1 CALL MPI_CART_RANK(MPL_COMM_GRID, IDIMS, IPROC, IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_CART_RANK: mpi_cart_rank') MPL_CART_RANK=IPROC+1 END FUNCTION MPL_CART_RANK ! ------------------------------------------------------------------ SUBROUTINE MPL_CART_COORDS(KPROC, KPROCW, KPROCV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_CART_COORDS => MPI_CART_COORDS8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KPROC INTEGER(KIND=JPIM), INTENT(OUT) :: KPROCW, KPROCV INTEGER(KIND=JPIM) :: IDIMS(2), IPROC, IERR IPROC=KPROC-1 CALL MPI_CART_COORDS(MPL_COMM_GRID, IPROC, 2, IDIMS, IERR) IF (IERR/=0) CALL MPL_MESSAGE(IERR,'MPL_CART_COORDS: mpi_cart_coords') KPROCW=IDIMS(1)+1 KPROCV=IDIMS(2)+1 END SUBROUTINE MPL_CART_COORDS ! ------------------------------------------------------------------ END MODULE MPL_GROUPS fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_mpif.F900000664000175000017500000000073115157200431024277 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MPIF #include "mpif.h" END MODULE MPL_MPIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_tour_table_mod.F900000664000175000017500000000312515157200431026343 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_TOUR_TABLE_MOD USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC, MPL_RANK, MPL_ERRUNIT USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_TOUR_TABLE CONTAINS SUBROUTINE MPL_TOUR_TABLE(KOPPONENT, KEVEN) INTEGER(KIND=JPIM),INTENT(OUT)::KOPPONENT(:) INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL::KEVEN INTEGER(KIND=JPIM) :: ICIRCULAR(MPL_NUMPROC+1) INTEGER(KIND=JPIM) :: IEVEN,IMYPOS,ITMP,JK,JI LOGICAL :: LLABORT=.TRUE. IEVEN = ((MPL_NUMPROC+1)/2)*2 IF(SIZE(KOPPONENT) < IEVEN) THEN WRITE(MPL_ERRUNIT,*)'MPL_TOUR_TABLE: ERROR KOPPONENT dimension=',& & SIZE(KOPPONENT),'. MUST BE AT LEAST=',IEVEN CALL MPL_MESSAGE(CDMESSAGE='MPL_TOUR_TABLE: ERROR KOPPONENT dimension wrong',& & LDABORT=LLABORT) ENDIF DO JK = 1,IEVEN ICIRCULAR(JK) = JK ENDDO KOPPONENT(:) = -1 IMYPOS = MPL_RANK DO JK=1,IEVEN-1 KOPPONENT(JK) = ICIRCULAR(IEVEN-IMYPOS+1) ITMP = ICIRCULAR(IEVEN-1) DO JI=IEVEN-2,1,-1 ICIRCULAR(JI+1) = ICIRCULAR(JI) ENDDO ICIRCULAR(1) = ITMP IF(MPL_RANK < IEVEN) IMYPOS = MOD(IMYPOS,IEVEN-1)+1 ENDDO KOPPONENT(IEVEN) = MPL_RANK IF (PRESENT(KEVEN)) KEVEN = IEVEN END SUBROUTINE MPL_TOUR_TABLE END MODULE MPL_TOUR_TABLE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_init_mod.F900000664000175000017500000002770615157200431025161 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_INIT_MOD !**** MPL_INIT - Initialises the Message passing environment ! Purpose. ! -------- ! Must be called before any other MPL routine. !** Interface. ! ---------- ! CALL MPL_INIT ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! KOUTPUT - Level of printing for MPL routines ! =0: none ! =1: intermediate (default) ! =2: full trace ! KUNIT - Fortran Unit to receive printed trace ! LDINFO - = .TRUE. : Print informative msgs from MPL_INIT (default) ! = .FALSE. : Do not print ! LDENV - = .TRUE. : Propagate environment variables across participating tasks (default) ! = .FALSE. : Do not propagate ! ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_INIT aborts when an error is detected. ! KPROCS - Number of processes which have been initialised ! in the MPI_COMM_WORLD communicator ! ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! R. El Khatib 14-May-2007 Do not propagate environment if NECSX ! S. Saarinen 04-Oct-2009 Reduced output & redefined MPL_COMM_OML(1) ! P. Marguinaud 01-Jan-2011 Add LDENV argument ! R. El Khatib 24-May-2011 Make MPI2 the default expectation. ! P. Towers 3-Jul-2014 Add call to ec_cray_meminfo ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_INIT, OML_GET_MAX_THREADS USE MPL_MPIF, ONLY : MPI_THREAD_MULTIPLE, MPI_THREAD_SINGLE, MPI_INTEGER, MPI_BYTE, MPI_COMM_WORLD USE MPL_DATA_MODULE, ONLY : JP_BLOCKING_BUFFERED, JP_BLOCKING_STANDARD, & & LFULLNODES, LINITMPI_VIA_MPL, LMPLUSERCOMM, LTHSAFEMPI, LUSEHLMPI, MPL_COMM, & & MPL_COMM_OML, MPL_IDS, MPL_MAX_TASK_PER_NODE, MPL_MBX_SIZE, MPL_METHOD, MPL_MYNODE, & & MPL_NNODES, MPL_NCPU_PER_NODE, MPL_NODE, MPL_NODE_TASKS, MPL_NUMPROC, MPL_OPPONENT, & & MPL_OUTPUT, MPL_RANK, MPL_TASK_PER_NODE, MPLUSERCOMM, MPL_UNIT, MPL_WORLD_RANK, & & MPL_WORLD_SIZE USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_BUFFER_METHOD_MOD, ONLY : MPL_BUFFER_METHOD USE MPL_TOUR_TABLE_MOD, ONLY : MPL_TOUR_TABLE USE MPL_LOCOMM_CREATE_MOD, ONLY : MPL_LOCOMM_CREATE USE MPL_ARG_MOD, ONLY : MPL_IARGC USE EC_ENV_MOD, ONLY : EC_PUTENV, EC_NUMENV, EC_ENVIRON IMPLICIT NONE PUBLIC MPL_INIT PRIVATE CONTAINS SUBROUTINE MPL_INIT(KOUTPUT,KUNIT,KERROR,KPROCS,LDINFO,LDENV) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_INITIALIZED => MPI_INITIALIZED8, MPI_INIT => MPI_INIT8, & MPI_COMM_SIZE => MPI_COMM_SIZE8, MPI_COMM_RANK => MPI_COMM_RANK8, & MPI_BCAST => MPI_BCAST8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KOUTPUT,KUNIT INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KPROCS LOGICAL,INTENT(IN),OPTIONAL :: LDINFO,LDENV INTEGER(KIND=JPIM) :: IERROR,IP,ICOMM,IRANK,JNODE,JROC,ISTA INTEGER(KIND=JPIM) :: IMAX_THREADS, IRET, IROOT, INUM(2), ICOUNT INTEGER(KIND=JPIM) :: IREQUIRED,IPROVIDED INTEGER(KIND=JPIM) :: IWORLD_RANK, IWORLD_SIZE INTEGER(KIND=JPIM) :: IME LOGICAL :: LLABORT=.TRUE., LLINFO LOGICAL :: LLINIT LOGICAL :: LLENV CHARACTER(LEN=12) :: CL_MBX_SIZE CHARACTER(LEN=12) :: CL_ARCH CHARACTER(LEN=12) :: CL_TASKSPERNODE CHARACTER(LEN=1024):: CLENV CHARACTER(LEN=20) :: CL_METHOD,CL_HOST CHARACTER(LEN=1) :: CL_SET IF(PRESENT(KOUTPUT)) THEN MPL_OUTPUT=MAX(0,KOUTPUT) ELSE MPL_OUTPUT=1 ENDIF IF(PRESENT(KUNIT)) THEN MPL_UNIT=MAX(0,KUNIT) ELSE MPL_UNIT=6 ENDIF IF(PRESENT(LDINFO)) THEN LLINFO = LDINFO ELSE LLINFO = .TRUE. ENDIF IF(PRESENT(LDENV)) THEN LLENV = LDENV ELSE LLENV = .TRUE. ENDIF IF(MPL_NUMPROC /= -1) THEN !! We do not want this extra message !! CALL MPL_MESSAGE(CDMESSAGE=' MPL_INIT CALLED MULTIPLE TIMES ') IF(PRESENT(KERROR)) THEN KERROR=0 ENDIF IF(PRESENT(KPROCS)) THEN KPROCS=MPL_NUMPROC ENDIF RETURN ENDIF CALL MPI_INITIALIZED(LLINIT, IRET) IF (.NOT.LLINIT) THEN CALL GET_ENVIRONMENT_VARIABLE('ARCH',CL_ARCH) #ifndef MPI1 IREQUIRED = MPI_THREAD_MULTIPLE IPROVIDED = MPI_THREAD_SINGLE CALL MPI_INIT_THREAD(IREQUIRED,IPROVIDED,IERROR) IF (IERROR /= 0) CALL ABOR1 ('MPL_INIT: MPI_INIT_THREAD FAILED') LTHSAFEMPI = (IPROVIDED >= IREQUIRED) #else CALL MPI_INIT(IERROR) IF (IERROR /= 0) CALL ABOR1 ('MPL_INIT: MPI_INIT FAILED') LTHSAFEMPI = .FALSE. #endif CALL MPI_Comm_rank(MPI_COMM_WORLD, IME, IERROR) ! Print out thread safety etc. messages -- must use MPI_Comm_rank since MPL not initialized just yet IF (IME == 0 .AND. LLINFO ) THEN WRITE(MPL_UNIT,'(4(A,I0),1(A,L1))') & & 'MPL_INIT : MPI_THREAD_MULTIPLE=',MPI_THREAD_MULTIPLE,' , MPI_THREAD_SINGLE=',MPI_THREAD_SINGLE,& & ' , IREQUIRED=',IREQUIRED,' , IPROVIDED=',IPROVIDED,' , LTHSAFEMPI=',LTHSAFEMPI ENDIF LINITMPI_VIA_MPL = .TRUE. ! CALL ec_mpi_atexit() ! ifsaux/support/endian.c: to make sure MPI_FINALIZE gets called ELSE IERROR = 0 ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0) THEN CALL MPL_MESSAGE(IERROR,CDMESSAGE=' MPL_INIT ERROR ',LDABORT=LLABORT) ENDIF ENDIF ! If LMPLUSERCOMM is not set use MPI_COMM_WORLD !mps: Sami Saarinen, 29-Nov-2016 ! Must be set *AFTER* MPI_INIT*() has ben called (or LLINIT is true) ! Otherwise MPI_COMM_WORLD not defined (at least not in OpenMPI) IF(LMPLUSERCOMM) THEN MPL_COMM = MPLUSERCOMM ELSE MPL_COMM = MPI_COMM_WORLD ENDIF CALL MPI_COMM_SIZE(MPL_COMM,MPL_NUMPROC,IERROR) IF(PRESENT(KPROCS)) THEN KPROCS=MPL_NUMPROC ENDIF ALLOCATE (MPL_IDS(MPL_NUMPROC)) DO IP=1,MPL_NUMPROC MPL_IDS(IP)=IP ENDDO CALL MPI_COMM_RANK(MPL_COMM, IRANK, IERROR) MPL_RANK=IRANK+1 IF (MPL_RANK == 1) THEN ! Clean up possible lockfile which gets created within MPL_ABORT CALL TABORT_DELETE_LOCKFILE() ENDIF LLINFO = LLINFO .AND. (MPL_RANK <= 1) IF (LLINFO) THEN IF(LMPLUSERCOMM) THEN WRITE(MPL_UNIT,'(2(A,I0))')'MPL_INIT : MPL_COMM=',MPL_COMM, ' (non-default) , MPL_NUMPROC=',MPL_NUMPROC ELSE WRITE(MPL_UNIT,'(2(A,I0))')'MPL_INIT : MPL_COMM=',MPL_COMM, ' (default) , MPL_NUMPROC=',MPL_NUMPROC ENDIF ENDIF !-- Propagate environment variables & argument lists ! Here we have to be careful and use MPI_BCAST directly (not MPL_BROADCAST) since ! 1) MPL_BUFFER_METHOD has not been called ! 2) MPL_COMM_OML has not been initialized since it is possible that only the ! master proc knows the # of threads (i.e. OMP_NUM_THREADS may be set only for master) ! Do not propagate on nec machine because the environment variables could be mpi-task-specific. IF (MPL_NUMPROC > 1 .AND. LLENV) THEN IROOT = 0 !-- Progate environment variables INUM(1) = 0 ! The number of environment variables INUM(2) = 0 ! Do not (=0) or do (=1) overwrite if particular environment variable already exists (0 = default) IF (MPL_RANK == 1) THEN ! Master proc inquires INUM(1) = EC_NUMENV() CALL GET_ENVIRONMENT_VARIABLE("EC_OVERWRITE_ENV",CLENV) IF( CLENV == '1' ) INUM(2) = 1 ENDIF ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(INUM(1),2,INT(MPI_INTEGER),IROOT,MPL_COMM,IERROR) ICOUNT = LEN(CLENV) DO IP=1,INUM(1) IF (MPL_RANK == 1) CALL EC_ENVIRON(IP,CLENV) ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(CLENV,ICOUNT,INT(MPI_BYTE),IROOT,MPL_COMM,IERROR) IF (MPL_RANK > 1) THEN IF (INUM(2) == 1) THEN CALL EC_PUTENV(CLENV,OVERWRITE=.TRUE.) ! ../support/env.c ; Unconditionally overwrite, even if already exists ELSE CALL EC_PUTENV(CLENV,OVERWRITE=.FALSE.) ! ../support/env.c ; Do not overwrite, if exists ENDIF ENDIF ENDDO !-- Propagate argument list (all under the bonnet using MPL_ARG_MOD-module) INUM = MPL_IARGC() ENDIF CALL OML_INIT() IMAX_THREADS = OML_GET_MAX_THREADS() ALLOCATE(MPL_COMM_OML(IMAX_THREADS)) IF (LMPLUSERCOMM) THEN MPL_COMM_OML(1) = MPLUSERCOMM ISTA = 2 ELSE ISTA = 1 ENDIF DO IP=ISTA,IMAX_THREADS CALL MPL_LOCOMM_CREATE(MPL_NUMPROC,MPL_COMM_OML(IP)) ENDDO MPL_COMM = MPL_COMM_OML(1) ! i.e. not necessary MPI_COMM_WORLD anymore CL_METHOD=' ' CALL GET_ENVIRONMENT_VARIABLE('MPL_METHOD',CL_METHOD) IF (CL_METHOD == 'JP_BLOCKING_STANDARD' ) THEN MPL_METHOD=JP_BLOCKING_STANDARD ELSE MPL_METHOD=JP_BLOCKING_BUFFERED ENDIF MPL_MBX_SIZE=1000000 CL_MBX_SIZE=' ' CALL GET_ENVIRONMENT_VARIABLE('MPL_MBX_SIZE',CL_MBX_SIZE) IF (CL_MBX_SIZE /= ' ') THEN READ(CL_MBX_SIZE,*) MPL_MBX_SIZE ENDIF IF (CL_METHOD == 'JP_BLOCKING_STANDARD' ) THEN IF (LLINFO) WRITE(MPL_UNIT,'(A,I0)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_STANDARD , MPL_MBX_SIZE=',MPL_MBX_SIZE ELSE IF (LLINFO) WRITE(MPL_UNIT,'(A,I0)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED , MPL_MBX_SIZE=',MPL_MBX_SIZE ENDIF CALL MPL_BUFFER_METHOD(KMP_TYPE=MPL_METHOD,KMBX_SIZE=MPL_MBX_SIZE,LDINFO=.FALSE.) LUSEHLMPI = .TRUE. CALL MPI_COMM_RANK (MPI_COMM_WORLD, IWORLD_RANK, IERROR) CALL MPI_COMM_SIZE (MPI_COMM_WORLD, IWORLD_SIZE, IERROR) #ifdef LINUX CALL LINUX_BIND (IWORLD_RANK, IWORLD_SIZE) #endif !-- World-wide tasks MPL_WORLD_RANK = IWORLD_RANK MPL_WORLD_SIZE = IWORLD_SIZE !!!! If you are not at ECMWF this may need changing!!!! CALL GET_ENVIRONMENT_VARIABLE('EC_TASKS_PER_NODE',CL_TASKSPERNODE) IF (CL_TASKSPERNODE(1:1) == ' ' ) THEN CALL GET_ENVIRONMENT_VARIABLE('HOST',CL_HOST) IF(CL_HOST(1:3) == 'cck') THEN ! KNL MPL_NCPU_PER_NODE=64 ELSEIF(CL_HOST(1:3) == 'cct') THEN ! Test-cluster MPL_NCPU_PER_NODE=24 ELSEIF(CL_HOST(1:2) == 'cc') THEN ! cca/ccb MPL_NCPU_PER_NODE=36 ELSEIF(CL_HOST(1:3) == 'lxg') THEN ! GPU-cluster MPL_NCPU_PER_NODE=24 ELSEIF (CL_HOST(1:2) == 'c1') THEN MPL_NCPU_PER_NODE=64 ELSEIF(CL_HOST(1:3) == 'hpc') THEN MPL_NCPU_PER_NODE=32 ELSE MPL_NCPU_PER_NODE=1 !IF(LLINFO) WRITE(MPL_UNIT,'(A)')'MPL_INIT : MPL_NCPU_PER_NODE = 1 (CAUTION: could not be inferred from hostname!)' ENDIF ELSE READ(CL_TASKSPERNODE,*) MPL_NCPU_PER_NODE ENDIF MPL_MAX_TASK_PER_NODE=MAX(1, MPL_NCPU_PER_NODE/IMAX_THREADS) LFULLNODES=MOD(MPL_NUMPROC,MPL_MAX_TASK_PER_NODE) == 0 MPL_NNODES=(MPL_NUMPROC-1)/MPL_MAX_TASK_PER_NODE+1 ALLOCATE(MPL_TASK_PER_NODE(MPL_NNODES)) ALLOCATE(MPL_NODE(MPL_NUMPROC)) ALLOCATE(MPL_NODE_TASKS(MPL_NNODES,MPL_MAX_TASK_PER_NODE)) MPL_NODE_TASKS(:,:)=-99 ICOUNT=0 DO JNODE=1,MPL_NNODES DO JROC=1,MPL_MAX_TASK_PER_NODE ICOUNT=ICOUNT+1 IF (ICOUNT<=MPL_NUMPROC) THEN MPL_NODE(ICOUNT)=JNODE MPL_TASK_PER_NODE(JNODE) = JROC MPL_NODE_TASKS(JNODE,JROC) = ICOUNT ENDIF ENDDO ENDDO MPL_MYNODE=(MPL_RANK-1)/MPL_MAX_TASK_PER_NODE+1 !WRITE(MPL_UNIT,*) 'MPL_INIT : NCPU_PER_NODE,MPL_MAX_TASK_PER_NODE,MPL_NNODES,MPL_MYNODE ',& ! & MPL_NCPU_PER_NODE,MPL_MAX_TASK_PER_NODE,MPL_NNODES,MPL_MYNODE !WRITE(MPL_UNIT,*) 'MPL_INIT : MPL_NODE_TASKS(MPL_MYNODE,1:MPL_TASK_PER_NODE(MPL_MYNODE)) ', & ! & MPL_NODE_TASKS(MPL_MYNODE,1:MPL_TASK_PER_NODE(MPL_MYNODE)) ALLOCATE(MPL_OPPONENT(MPL_NUMPROC+1)) CALL MPL_TOUR_TABLE(MPL_OPPONENT) RETURN END SUBROUTINE MPL_INIT END MODULE MPL_INIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_open_mod.F900000664000175000017500000000647215157200431025154 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_OPEN_MOD ! ! Purpose. open an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_open(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! ktype - 1 = open for reading , 2 = writing ! kname - Name of the file ! output arguments: ! kfptr - handle for file pointer ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_OPEN) ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_INFO_NULL, MPI_MODE_CREATE, MPI_MODE_RDONLY, MPI_MODE_WRONLY USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_COMM_IO, MPL_NUMIO IMPLICIT NONE PRIVATE PUBLIC MPL_OPEN CONTAINS SUBROUTINE MPL_OPEN(KFPTR,KTYPE,KNAME,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_OPEN => MPI_FILE_OPEN8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE INTEGER(KIND=JPIM),INTENT(OUT) :: KFPTR,KERROR CHARACTER(LEN=*) KNAME INTEGER(KIND=JPIM) :: MODE,INFO #ifndef MPI1 ! ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- ! IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KTYPE == 1 ) THEN MODE = MPI_MODE_RDONLY ELSEIF( KTYPE == 2 ) THEN MODE = MPI_MODE_WRONLY + MPI_MODE_CREATE ELSE KERROR = -1 RETURN ENDIF INFO = MPI_INFO_NULL ! ----------------------------------------------------------------- ! ! 2. open the file ! ---------------------- CALL MPI_FILE_OPEN(MPL_COMM_IO,KNAME,MODE,INFO,KFPTR,KERROR) ! ! ! ----------------------------------------------------------------- #else CALL ABOR1('MPL_OPEN not built with MPI2') #endif RETURN END SUBROUTINE MPL_OPEN END MODULE MPL_OPEN_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_write_mod.F900000664000175000017500000002021015157200431025327 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_WRITE_MOD ! ! Purpose. write to an MPIIO file ! -------- ! ! ! Interface. ! ---------- ! call mpl_write(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kfptr - handle for file ! kop - requested operation ! kbuf - buffer containing data to be written ! klen - length of buffer in words ! input/output arguements: ! kreq - request handle for non-blocking operations ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_WRITE) ! R. EL Khatib 24-May-2011 Change ifdef MPI2 into ifndef MPI1 ! ----------------------------------------------------------------- ! USE EC_PARKIND, ONLY : JPIM ,JPRM USE MPL_MPIF, ONLY : MPI_STATUS_SIZE, MPI_INTEGER, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_RANK USE MPL_IOINIT_MOD, ONLY : MPL_NUMIO, MPL_IOP IMPLICIT NONE INTERFACE MPL_WRITE MODULE PROCEDURE MPL_WRITE_INT,MPL_WRITE_REAL8 END INTERFACE PRIVATE PUBLIC MPL_WRITE CONTAINS SUBROUTINE MPL_WRITE_INT(KFPTR,KOP,KBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_WRITE_SHARED => MPI_FILE_WRITE_SHARED8, & MPI_FILE_WRITE_ORDERED => MPI_FILE_WRITE_ORDERED8, & MPI_FILE_IWRITE_SHARED => MPI_FILE_IWRITE_SHARED8, & MPI_FILE_WRITE_ORDERED_BEGIN => MPI_FILE_WRITE_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, & MPI_FILE_WRITE_ORDERED_END => MPI_FILE_WRITE_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) KBUF(:) INTEGER(KIND=JPIM) KREQ INTEGER(KIND=JPIM) STATUS(MPI_STATUS_SIZE) ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking write, non collective, shared file pointer CALL MPI_FILE_WRITE_SHARED(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking write, non collective, shared file pointer CALL MPI_FILE_IWRITE_SHARED(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED_BEGIN(KFPTR,& & KBUF,& & KLEN,& & MPI_INTEGER,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_WRITE_ORDERED_END(KFPTR,& & KBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF #else CALL ABOR1('MPL_WRITE_INT not built with MPI2') #endif ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_WRITE_INT SUBROUTINE MPL_WRITE_REAL8(KFPTR,KOP,PBUF,KLEN,KREQ,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_FILE_WRITE_SHARED => MPI_FILE_WRITE_SHARED8, & MPI_FILE_WRITE_ORDERED => MPI_FILE_WRITE_ORDERED8, & MPI_FILE_IWRITE_SHARED => MPI_FILE_IWRITE_SHARED8, & MPI_FILE_WRITE_ORDERED_BEGIN => MPI_FILE_WRITE_ORDERED_BEGIN8, & MPI_WAIT => MPI_WAIT8, & MPI_FILE_WRITE_ORDERED_END => MPI_FILE_WRITE_ORDERED_END8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KFPTR,KOP,KLEN INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR REAL(KIND=JPRM) PBUF(:) INTEGER(KIND=JPIM) KREQ INTEGER(KIND=JPIM) STATUS(MPI_STATUS_SIZE) ! #ifndef MPI1 ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF( MPL_RANK > MPL_NUMIO ) THEN KERROR = -1 RETURN ENDIF IF( KOP >= 1.AND.KOP <= 4 ) THEN IF( KOP /= MPL_IOP ) THEN KERROR = -1 RETURN ENDIF ENDIF ! ----------------------------------------------------------------- ! ! 2. Check style and take appropriate action ! --------------------------------------- IF( KOP == 1 ) THEN ! blocking write, non collective, shared file pointer CALL MPI_FILE_WRITE_SHARED(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 2 ) THEN ! blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & STATUS,& & KERROR) ELSEIF( KOP == 3 ) THEN ! non blocking write, non collective, shared file pointer CALL MPI_FILE_IWRITE_SHARED(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & KREQ,& & KERROR) ELSEIF( KOP == 4 ) THEN ! non blocking write, collective, ordered with shared file pointer CALL MPI_FILE_WRITE_ORDERED_BEGIN(KFPTR,& & PBUF,& & KLEN,& & MPI_REAL8,& & KERROR) ELSEIF( KOP == 5 ) THEN CALL MPI_WAIT(KREQ,& & STATUS,& & KERROR ) ELSEIF( KOP == 6 ) THEN CALL MPI_FILE_WRITE_ORDERED_END(KFPTR,& & PBUF,& & STATUS,& & KERROR) ELSE KERROR =-1 RETURN ENDIF #else CALL ABOR1('MPL_WRITE_REAL8 not built with MPI2') #endif ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_WRITE_REAL8 END MODULE MPL_WRITE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_testsome_mod.F900000664000175000017500000000524115157200431026047 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_TESTSOME_MOD USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_STATUS_SIZE USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE ! P. Marguinaud : 01-Jan-2011 ! KARRAY_OF_REQUESTS (see MPI_TESTSOME) ! KARRAY_OF_INDICES (see MPI_TESTSOME) ! KARRAY_OF_INDICES1 pending requests ! KOUTCOUNT1 number of pending requests PRIVATE PUBLIC :: MPL_TESTSOME CONTAINS SUBROUTINE MPL_TESTSOME (KARRAY_OF_REQUESTS, KARRAY_OF_INDICES, & & KARRAY_OF_INDICES1, KOUTCOUNT, KOUTCOUNT1, & & KERROR, CDSTRING, LDWAIT) INTEGER(KIND=JPIM), INTENT (IN) :: KARRAY_OF_REQUESTS (:) INTEGER(KIND=JPIM), INTENT (OUT) :: KARRAY_OF_INDICES (:) INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KARRAY_OF_INDICES1 (:) INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KOUTCOUNT INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KOUTCOUNT1 INTEGER(KIND=JPIM), INTENT (OUT), OPTIONAL :: KERROR CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: CDSTRING LOGICAL, INTENT(IN), OPTIONAL :: LDWAIT INTEGER(KIND=JPIM) :: IERROR INTEGER(KIND=JPIM) :: IINCOUNT INTEGER(KIND=JPIM) :: IOUTCOUNT INTEGER(KIND=JPIM) :: IARRAY_OF_STATUSES (MPI_STATUS_SIZE, SIZE (KARRAY_OF_REQUESTS)) INTEGER(KIND=JPIM) :: II, IJ, IK LOGICAL :: LLWAIT LOGICAL :: LLABORT=.TRUE. IINCOUNT = SIZE (KARRAY_OF_REQUESTS) KARRAY_OF_INDICES = -1 LLWAIT = .FALSE. IF (PRESENT (LDWAIT)) LLWAIT = LDWAIT IF (LLWAIT) THEN CALL MPI_WAITSOME(IINCOUNT, KARRAY_OF_REQUESTS, IOUTCOUNT, & KARRAY_OF_INDICES, IARRAY_OF_STATUSES, IERROR) ELSE CALL MPI_TESTSOME(IINCOUNT, KARRAY_OF_REQUESTS, IOUTCOUNT, & KARRAY_OF_INDICES, IARRAY_OF_STATUSES, IERROR) ENDIF IF (PRESENT (KOUTCOUNT)) THEN KOUTCOUNT = IOUTCOUNT ENDIF IF (PRESENT (KOUTCOUNT1)) THEN KOUTCOUNT1 = IINCOUNT - IOUTCOUNT ENDIF IF (PRESENT (KARRAY_OF_INDICES1)) THEN KARRAY_OF_INDICES1 = -1 IJ = 1 IK = 1 DO II = 1, IINCOUNT IF (II .EQ. KARRAY_OF_INDICES (IJ)) THEN IJ = IJ + 1 ELSE KARRAY_OF_INDICES1 (IK) = II IK = IK + 1 ENDIF ENDDO ENDIF IF (PRESENT (KERROR)) THEN KERROR = IERROR ELSE IF(IERROR /= 0) CALL MPL_MESSAGE(IERROR,'MPL_TESTSOME',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_TESTSOME END MODULE MPL_TESTSOME_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_setdflt_comm_mod.F900000664000175000017500000000400415157200431026660 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_SETDFLT_COMM_MOD !**** MPL_SETDFLT_COMM Set new default communicator ! Purpose. ! -------- ! Set new communicator as default, and return old communicator !** Interface. ! ---------- ! CALL MPL_SETDFLT_COMM(KCOMM,KCOMM_OLD) ! Input required arguments : ! ------------------------- ! KCOMM - New communicator ! Input optional arguments : ! ------------------------- ! Output required arguments : ! ------------------------- ! KCOMM_OLD - Old communicator ! Output optional arguments : ! ------------------------- ! Author. ! ------- ! J.Hague ! Modifications. ! -------------- ! Original: 2003-16-07 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_RANK, MPL_NUMPROC IMPLICIT NONE PRIVATE PUBLIC MPL_SETDFLT_COMM CONTAINS SUBROUTINE MPL_SETDFLT_COMM(KCOMM,KCOMM_OLD) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT) :: KCOMM_OLD INTEGER(KIND=JPIM) :: IER INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIM) :: IRANK ITID = OML_MY_THREAD() KCOMM_OLD=MPL_COMM_OML(ITID) MPL_COMM_OML(ITID)=KCOMM ! Get rank in and size of new communicator CALL MPI_COMM_RANK(KCOMM, IRANK, IER) MPL_RANK = IRANK + 1 CALL MPI_COMM_SIZE(KCOMM, MPL_NUMPROC, IER) RETURN END SUBROUTINE MPL_SETDFLT_COMM END MODULE MPL_SETDFLT_COMM_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_data_module.F900000664000175000017500000000655715157200431025636 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_DATA_MODULE ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ ! variables controlling the execution of MPL ! MPL_METHOD : buffering type ! MPL_MBX_SIZE : size of application mailbox, (bytes) ! used when MPL_METHOD=JP_BLOCKING_BUFFERED ! MPL_COMM : default communicator in use ! MPL_COMM_OML : communicators for messages between corresponding OML-threads ! MPL_UNIT : Fortran I/O unit for messages (default=6) ! MPL_ERRUNIT : Fortran I/O unit for error messages (default=0) ! MPL_OUTPUT : controls contents of Output (see mpl_init_mod.F90 for values/default) ! MPL_RANK : rank of the process within MPL_COMM_OML(1) ! MPL_NUMPROC : number of processes in MPL_COMM_OML(1) ! MPL_IDS : array of processor numbers ! LUSEHLMPI : always use high level MPI calls (collective comm.) ! LINITMPI_VIA_MPL : true if MPI has been initialized from within MPL_INIT() ! LTHSAFEMPI : Thread safe MPI, if .TRUE. (default) USE MPL_MPIF , ONLY : MPI_COMM_WORLD USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE PRIVATE :: JPIM SAVE PUBLIC INTEGER(KIND=JPIM) :: MPL_METHOD, MPL_MBX_SIZE, MPL_UNIT=6, MPL_OUTPUT=1 INTEGER(KIND=JPIM) :: MPL_RANK=0,MPL_NUMPROC = -1,MPL_ERRUNIT=0 INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_IDS(:) INTEGER(KIND=JPIM) :: MPL_COMM INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_COMM_OML(:) INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_OPPONENT(:) INTEGER(KIND=JPIM) :: MPL_NCPU_PER_NODE=1 INTEGER(KIND=JPIM) :: MPL_MAX_TASK_PER_NODE INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_TASK_PER_NODE(:) INTEGER(KIND=JPIM) :: MPL_NNODES LOGICAL :: LFULLNODES INTEGER(KIND=JPIM) :: MPL_MYNODE=0 INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_NODE(:) INTEGER(KIND=JPIM),ALLOCATABLE :: MPL_NODE_TASKS(:,:) !INTEGER_M,ALLOCATABLE :: MPL_ATTACHED_BUFFER(:) ! needs to ge a TARGET for coexistence with MPE INTEGER(KIND=JPIM),ALLOCATABLE,TARGET :: MPL_ATTACHED_BUFFER(:) LOGICAL :: LUSEHLMPI LOGICAL :: LINITMPI_VIA_MPL = .FALSE. LOGICAL :: LTHSAFEMPI = .TRUE. INTEGER(KIND=JPIM),PARAMETER :: JP_ATTACHED_BUFFER_BYTES = JPIM INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_STANDARD = 1 INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_BUFFERED = 2 INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_SYNCHRONOUS = 3 INTEGER(KIND=JPIM),PARAMETER :: JP_BLOCKING_READY = 4 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_STANDARD = 5 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_BUFFERED = 6 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_SYNCHRONOUS = 7 INTEGER(KIND=JPIM),PARAMETER :: JP_NON_BLOCKING_READY = 8 LOGICAL :: LMPLUSERCOMM = .FALSE. INTEGER(KIND=JPIM) :: MPLUSERCOMM = -1 INTEGER(KIND=JPIM) :: MPL_SEND_COUNT, MPL_SEND_BYTES INTEGER(KIND=JPIM) :: MPL_RECV_COUNT, MPL_RECV_BYTES INTEGER(KIND=JPIM) :: MPL_WORLD_RANK = -1 INTEGER(KIND=JPIM) :: MPL_WORLD_SIZE = 0 END MODULE MPL_DATA_MODULE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpi4to8.F900000664000175000017500000000074215157200431024002 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI4TO8 USE MPI4TO8_S USE MPI4TO8_M END MODULE MPI4TO8 fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_end_mod.F900000664000175000017500000000740615157200431024757 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_END_MOD !**** MPL_END - Terminates the message passing environment ! Purpose. ! -------- ! Cleans up all of the MPI state. ! Subsequently, no MPI routine can be called !** Interface. ! ---------- ! CALL MPL_END ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! LDMEMINFO - print memory info (default True) ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_END aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P. Towers 3-Jul-2014 Add call to ec_cray_meminfo ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE MPL_DATA_MODULE, ONLY : LINITMPI_VIA_MPL, MPL_NUMPROC, MPL_ATTACHED_BUFFER, JP_ATTACHED_BUFFER_BYTES USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PUBLIC MPL_END PRIVATE INTEGER :: IERROR CONTAINS SUBROUTINE MPL_END(KERROR,LDMEMINFO) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_BUFFER_DETACH => MPI_BUFFER_DETACH8, MPI_FINALIZE => MPI_FINALIZE8 #endif INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR LOGICAL ,INTENT(IN), OPTIONAL :: LDMEMINFO INTEGER(KIND=JPIM) :: IBUFFMPI,IERROR LOGICAL :: LLMEMINFO LOGICAL,parameter :: LLABORT=.TRUE. #include "ec_mpi_finalize.intfb.h" IF(MPL_NUMPROC < 1) THEN IF(MPL_NUMPROC == -1) THEN IF (.NOT.LINITMPI_VIA_MPL) THEN ! Neither MPL_INIT_MOD nor MPL_ARG_MOD -modules were called before this CALL MPL_MESSAGE(CDMESSAGE=' MPL_END CALLED BEFORE MPL_INIT ') ENDIF !!-- we do not want the following message to appear, since its non-fatal !! ELSEIF(MPL_NUMPROC == -2) THEN !! CALL MPL_MESSAGE(CDMESSAGE=' MPL_END CALLED MULTIPLE TIMES ') ENDIF IF(PRESENT(KERROR)) THEN IERROR=0 KERROR=IERROR ENDIF RETURN ENDIF IF (ALLOCATED(MPL_ATTACHED_BUFFER)) THEN IF( MPI_IS_FINALIZED() ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_END -- Cannot call MPI_Buffer_detach() as MPI is already finalized',LDABORT=.FALSE.) ELSE IBUFFMPI=SIZE(MPL_ATTACHED_BUFFER) * JP_ATTACHED_BUFFER_BYTES ! in bytes CALL MPI_BUFFER_DETACH(MPL_ATTACHED_BUFFER,IBUFFMPI,IERROR) IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF( IERROR /= 0 )THEN CALL MPL_MESSAGE(IERROR,'MPL_END ',LDABORT=LLABORT) ENDIF ENDIF ENDIF DEALLOCATE(MPL_ATTACHED_BUFFER) ENDIF LLMEMINFO=.TRUE. IF(PRESENT(LDMEMINFO)) LLMEMINFO=LDMEMINFO CALL EC_MPI_FINALIZE(IERROR,LINITMPI_VIA_MPL,LLMEMINFO,"mpl_end") MPL_NUMPROC = -2 LINITMPI_VIA_MPL = .FALSE. IF(PRESENT(KERROR)) THEN KERROR=IERROR ENDIF RETURN END SUBROUTINE MPL_END FUNCTION MPI_IS_FINALIZED() LOGICAL :: MPI_IS_FINALIZED LOGICAL :: LLINIT, LLFIN INTEGER(KIND=JPIM) :: IERR MPI_IS_FINALIZED = .FALSE. CALL MPI_INITIALIZED(LLINIT,IERR) IF (LLINIT .AND. IERR == 0) THEN CALL MPI_FINALIZED(LLFIN,IERR) IF( IERR == 0 ) THEN MPI_IS_FINALIZED = LLFIN ENDIF ENDIF END FUNCTION END MODULE MPL_END_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_allreduce_mod.F900000664000175000017500000006151315157200431026150 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLREDUCE_MOD !**** MPL_ALLREDUCE Perform collective communication ! Purpose. ! -------- ! To calculate global MIN,MAX,SUM or IEOR and return result to all processes. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array or scalar !** Interface. ! ---------- ! CALL MPL_ALLREDUCE ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message to be collectively communicated ! (can be type REAL*4, REAL*8 or INTEGER) (also output) ! CDOPER - Global operation to be performed : 'MAX', 'MIN', 'SUM' or 'IEOR' ! Input optional arguments : ! ------------------------- ! LDREPROD - Reproducibility flag for SUMmation-operator. ! Meaningful only for REAL-numbers. ! Three modes (applicable for REAL-number only): ! 1) Not provided at all (the default) ==> MPL_ABORT ! 2) Provided and .TRUE. ==> Use home-written binary tree ! No MPI_ALLREDUCE used. ! 3) Provided, but .FALSE. ==> let MPI_ALLREDUCE do the summation. ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_ALLREDUCE aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud, S.Saarinen ECMWF ! Modifications. ! -------------- ! Original: 2001-02-02 ! F. Vana 05-Mar-2015 Support for single precision ! E. Arbogast 11-Jul-2022 Allocate ZRECVBUF in the heap to fix bug ! detected in VARBC_PRED:PRED_STATS ! ------------------------------------------------------------------ USE EC_PARKIND , ONLY : JPRD, JPIM, JPRM, JPIB USE OML_MOD ,ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_INTEGER, MPI_INTEGER8, MPI_REAL4, MPI_REAL8, MPI_MIN, MPI_MAX, MPI_SUM, MPI_BXOR USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_ERRUNIT, MPL_NUMPROC, MPL_OUTPUT, MPL_RANK, MPL_UNIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_SEND_MOD, ONLY : MPL_SEND USE MPL_RECV_MOD, ONLY : MPL_RECV USE MPL_WAIT_MOD, ONLY : MPL_WAIT USE MPL_BROADCAST_MOD, ONLY : MPL_BROADCAST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_ALLREDUCE MODULE PROCEDURE MPL_ALLREDUCE_REAL8, MPL_ALLREDUCE_REAL4, MPL_ALLREDUCE_INT, & MPL_ALLREDUCE_INT8, & MPL_ALLREDUCE_REAL8_SCALAR, MPL_ALLREDUCE_REAL4_SCALAR, & MPL_ALLREDUCE_INT_SCALAR, MPL_ALLREDUCE_INT8_SCALAR, & MPL_ALLREDUCE_REAL4_2D, MPL_ALLREDUCE_REAL8_2D END INTERFACE PUBLIC MPL_ALLREDUCE CONTAINS SUBROUTINE MPL_ALLREDUCE_INT_SCALAR(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) INTEGER(KIND=JPIM),INTENT(INOUT) :: KSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) ISENDBUF(1) ISENDBUF(1) = KSENDBUF CALL MPL_ALLREDUCE(ISENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) KSENDBUF = ISENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_INT_SCALAR SUBROUTINE MPL_ALLREDUCE_INT8_SCALAR(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) INTEGER(KIND=JPIB),INTENT(INOUT) :: KSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIB) ISENDBUF(1) ISENDBUF(1) = KSENDBUF CALL MPL_ALLREDUCE(ISENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) KSENDBUF = ISENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_INT8_SCALAR SUBROUTINE MPL_ALLREDUCE_REAL8_SCALAR(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) REAL(KIND=JPRD),INTENT(INOUT) :: PSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRD) ZSENDBUF(1) ZSENDBUF(1) = PSENDBUF CALL MPL_ALLREDUCE(ZSENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) PSENDBUF = ZSENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_REAL8_SCALAR SUBROUTINE MPL_ALLREDUCE_REAL4_SCALAR(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) REAL(KIND=JPRM),INTENT(INOUT) :: PSENDBUF CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRM) ZSENDBUF(1) ZSENDBUF(1) = PSENDBUF CALL MPL_ALLREDUCE(ZSENDBUF,CDOPER,LDREPROD,KCOMM,KERROR,CDSTRING) PSENDBUF = ZSENDBUF(1) END SUBROUTINE MPL_ALLREDUCE_REAL4_SCALAR SUBROUTINE MPL_ALLREDUCE_INT(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif INTEGER(KIND=JPIM),INTENT(INOUT) :: KSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM), ALLOCATABLE :: IRECVBUF(:) INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IERROR = 0 ALLOCATE(IRECVBUF(SIZE(KSENDBUF))) IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM ELSEIF(CDOPER(1:4) == 'IEOR' .OR. CDOPER(1:4) == 'ieor' ) THEN IOPER = MPI_BXOR ELSEIF(CDOPER(1:4) == 'XOR' .OR. CDOPER(1:4) == 'xor' ) THEN IOPER = MPI_BXOR ELSE CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(KSENDBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(KSENDBUF(UBOUND(KSENDBUF,1)))-LOC(KSENDBUF(LBOUND(KSENDBUF,1)))) /= 4_JPIB*(ISENDCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(KSENDBUF,IRECVBUF,ISENDCOUNT,INT(MPI_INTEGER), & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_INTEGER)) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & KSENDBUF(:) = IRECVBUF(:) DEALLOCATE(IRECVBUF) END SUBROUTINE MPL_ALLREDUCE_INT SUBROUTINE MPL_ALLREDUCE_INT8(KSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) INTEGER(KIND=JPIB),INTENT(INOUT) :: KSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIB) :: IRECVBUF(SIZE(KSENDBUF)) INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM ELSEIF(CDOPER(1:4) == 'IEOR' .OR. CDOPER(1:4) == 'ieor' ) THEN IOPER = MPI_BXOR ELSEIF(CDOPER(1:4) == 'XOR' .OR. CDOPER(1:4) == 'xor' ) THEN IOPER = MPI_BXOR ELSE CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(KSENDBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(KSENDBUF(UBOUND(KSENDBUF,1)))-LOC(KSENDBUF(LBOUND(KSENDBUF,1)))) /= 8_JPIB*(ISENDCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(KSENDBUF,IRECVBUF,ISENDCOUNT,MPI_INTEGER8, & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_INTEGER8)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_INTEGER8)) ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & KSENDBUF(:) = IRECVBUF(:) END SUBROUTINE MPL_ALLREDUCE_INT8 SUBROUTINE MPL_ALLREDUCE_REAL8(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRD),INTENT(INOUT) :: PSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRD), ALLOCATABLE :: ZRECVBUF(:) INTEGER(KIND=JPIM) ITAG, ICOUNT LOGICAL LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER INTEGER(KIND=JPIM) :: IP2,II,IHALF,JSTAGE,ISEND,IRECV,IMSENT INTEGER(KIND=JPIM) :: ISREQ(MPL_NUMPROC) INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. ALLOCATE(ZRECVBUF(SIZE(PSENDBUF))) IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(IERROR,& & 'MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1)))-LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 8_JPIB*(ISENDCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF (LLREPRODSUM) THEN !-- Near reproducible summation (independent of number of threads) IP2=0 DO IP2=IP2+1 IF(2**IP2 >= MPL_NUMPROC) EXIT ENDDO IMSENT=0 DO JSTAGE=IP2,1,-1 ! WRITE(0,*) 'STAGE ',JSTAGE ITAG = 2001+JSTAGE II = 2**JSTAGE IHALF = II/2 ISEND = MPL_RANK - IHALF IF(ISEND > 0 .AND. MPL_RANK <= II) THEN IMSENT=IMSENT+1 CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT),CDSTRING='MPLS_SEND') ! write(0,*) 'I SEND TO ',MPL_RANK,ISEND ENDIF IRECV=MPL_RANK + IHALF IF(IRECV <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM,KTAG=ITAG,& &KERROR=IERROR,KOUNT=ICOUNT) ! write(0,*) 'I RECV FROM ',MPL_RANK,IRECV PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ENDIF ENDDO IF(IMSENT > 0) THEN CALL MPL_WAIT(KREQUEST=ISREQ(1:IMSENT),CDSTRING='MPLS_SEND') ENDIF IF (MPL_RANK == 1) THEN ZRECVBUF(:) = PSENDBUF(:) ENDIF ! write(0,*) 'enter broadcast ' CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM,KROOT=1,KERROR=IERROR) ! write(0,*) 'exit broadcast ' !!$ IMSENT=0 !!$ DO JSTAGE=1,IP2 !!$ ITAG = 2001+JSTAGE !!$ WRITE(0,*) 'STAGE BACK ',JSTAGE !!$ II = 2**JSTAGE !!$ IHALF = II/2 !!$ ISEND=MPL_RANK + IHALF !!$ IF(ISEND <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN !!$ IMSENT=IMSENT+1 !!$ CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& !!$ &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT),CDSTRING='MPLS_SEND') !!$ WRITE(0,*) 'I SEND BACK TO ',MPL_RANK,ISEND !!$ ENDIF !!$ IRECV=MPL_RANK - IHALF !!$ IF(IRECV > 0 .AND. MPL_RANK <= II) THEN !!$ WRITE(0,*) 'I RECV BACK FROM ',MPL_RANK,IRECV !!$ CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM,KTAG=ITAG,& !!$ &KERROR=IERROR,KOUNT=ICOUNT) !!$ ENDIF !!$ ENDDO !!$ IF(IMSENT > 0) THEN !!$ CALL MPL_WAIT(KREQUEST=ISREQ(1:IMSENT),CDSTRING='MPLS_SEND') !!$ ENDIF ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,INT(MPI_REAL8), & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_REAL8)) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:) = ZRECVBUF(:) DEALLOCATE(ZRECVBUF) END SUBROUTINE MPL_ALLREDUCE_REAL8 SUBROUTINE MPL_ALLREDUCE_REAL8_2D(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRD),INTENT(INOUT) :: PSENDBUF(:,:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRD) :: ZRECVBUF(SIZE(PSENDBUF(:,1)),SIZE(PSENDBUF(1,:))) INTEGER(KIND=JPIM) ITAG, ICOUNT LOGICAL LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER INTEGER(KIND=JPIM) :: IP2,II,IHALF,JSTAGE,ISEND,IRECV,IMSENT INTEGER(KIND=JPIM) :: ISREQ(MPL_NUMPROC) INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(IERROR,& & 'MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) !#ifndef NAGFOR !IF (ISENDCOUNT > 0) THEN ! IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1)))-LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 8_JPIB*(ISENDCOUNT - 1) ) THEN ! CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ! ENDIF !ENDIF !#endif !IF (LLREPRODSUM) THEN !-- Near reproducible summation (independent of number of threads) ! IP2=0 ! DO ! IP2=IP2+1 ! IF(2**IP2 >= MPL_NUMPROC) EXIT ! ENDDO ! IMSENT=0 ! DO JSTAGE=IP2,1,-1 ! WRITE(0,*) 'STAGE ',JSTAGE ! ITAG = 2001+JSTAGE ! II = 2**JSTAGE ! IHALF = II/2 ! ISEND = MPL_RANK - IHALF ! IF(ISEND > 0 .AND. MPL_RANK <= II) THEN ! IMSENT=IMSENT+1 ! CALL MPL_SEND(PSENDBUF,KDEST=ISEND,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& ! &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISREQ(IMSENT),CDSTRING='MPLS_SEND') ! write(0,*) 'I SEND TO ',MPL_RANK,ISEND ! ENDIF ! IRECV=MPL_RANK + IHALF ! IF(IRECV <=MPL_NUMPROC .AND. MPL_RANK <= IHALF) THEN ! CALL MPL_RECV(ZRECVBUF,KSOURCE=IRECV,KCOMM=ICOMM,KTAG=ITAG,& ! &KERROR=IERROR,KOUNT=ICOUNT) ! write(0,*) 'I RECV FROM ',MPL_RANK,IRECV ! PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ! ENDIF ! ENDDO ! IF(IMSENT > 0) THEN ! CALL MPL_WAIT(KREQUEST=ISREQ(1:IMSENT),CDSTRING='MPLS_SEND') ! ENDIF ! IF (MPL_RANK == 1) THEN ! ZRECVBUF(:) = PSENDBUF(:) ! ENDIF ! write(0,*) 'enter broadcast ' ! CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM,KROOT=1,KERROR=IERROR) ! write(0,*) 'exit broadcast ' !ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,INT(MPI_REAL8), & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL8)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_REAL8)) ENDIF !ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:,:) = ZRECVBUF(:,:) END SUBROUTINE MPL_ALLREDUCE_REAL8_2D SUBROUTINE MPL_ALLREDUCE_REAL4(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRM),INTENT(INOUT) :: PSENDBUF(:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRM), ALLOCATABLE :: ZRECVBUF(:) INTEGER(KIND=JPIM) IPROC, ITAG, ICOUNT LOGICAL LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. ALLOCATE(ZRECVBUF(SIZE(PSENDBUF))) IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(IERROR,& & 'MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1)))-LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 4_JPIB*(ISENDCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF (LLREPRODSUM) THEN !-- Near reproducible summation ITAG = 2001 IF (MPL_RANK == 1) THEN DO IPROC=2,MPL_NUMPROC CALL MPL_RECV(ZRECVBUF,KSOURCE=IPROC,KCOMM=ICOMM,KTAG=ITAG,& &KERROR=IERROR,KOUNT=ICOUNT) IF (ICOUNT /= ISENDCOUNT) THEN WRITE(MPL_ERRUNIT,'(A,I10,A,I6,A,I10)')& & 'MPL_ALLREDUCE: RECEIVED UNEXPECTED NUMBER OF ELEMENTS ', & & ICOUNT,' FROM PROC ',IPROC,'. EXPECTED=',ISENDCOUNT CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ENDDO ZRECVBUF(:) = PSENDBUF(:) ELSE CALL MPL_SEND(PSENDBUF,KDEST=1,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='MPLS_SEND') ENDIF ITAG = ITAG + 1 CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM,KROOT=1,KERROR=IERROR) ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,INT(MPI_REAL4), & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL4)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_REAL4)) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:) = ZRECVBUF(:) DEALLOCATE(ZRECVBUF) END SUBROUTINE MPL_ALLREDUCE_REAL4 SUBROUTINE MPL_ALLREDUCE_REAL4_2D(PSENDBUF,CDOPER,LDREPROD, & & KCOMM,KERROR,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLREDUCE => MPI_ALLREDUCE8 #endif REAL(KIND=JPRM),INTENT(INOUT) :: PSENDBUF(:,:) CHARACTER(LEN=*),INTENT(IN) :: CDOPER LOGICAL,INTENT(IN),OPTIONAL :: LDREPROD INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING REAL(KIND=JPRM) :: ZRECVBUF(SIZE(PSENDBUF(:,1)),SIZE(PSENDBUF(1,:))) INTEGER(KIND=JPIM) IPROC, ITAG, ICOUNT LOGICAL LLREPRODSUM INTEGER(KIND=JPIM) :: ISENDCOUNT,ICOMM,IERROR,IOPER INTEGER(KIND=JPIM) :: ITID IERROR = 0 ITID = OML_MY_THREAD() LLREPRODSUM = .FALSE. IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLREDUCE: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(CDOPER(1:3) == 'MAX' .OR. CDOPER(1:3) == 'max' ) THEN IOPER = MPI_MAX ELSEIF(CDOPER(1:3) == 'MIN' .OR. CDOPER(1:3) == 'min' ) THEN IOPER = MPI_MIN ELSEIF(CDOPER(1:3) == 'SUM' .OR. CDOPER(1:3) == 'sum' ) THEN IOPER = MPI_SUM IF (PRESENT(LDREPROD)) THEN LLREPRODSUM = LDREPROD ELSE CALL MPL_MESSAGE(IERROR,& & 'MPL_ALLREDUCE: SUMMATION OPERATOR NOT REPRODUCIBLE IN REAL MODE',& & CDSTRING,LDABORT=LLABORT) ENDIF ELSE CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE: ERROR UNKNOWN OPERATOR',& & CDSTRING,LDABORT=LLABORT) ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF ISENDCOUNT = SIZE(PSENDBUF) !#ifndef NAGFOR !IF (ISENDCOUNT > 0) THEN ! IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1)))-LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 4_JPIB*(ISENDCOUNT - 1) ) THEN ! CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLREDUCE: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ! ENDIF !ENDIF !#endif !IF (LLREPRODSUM) THEN !-- Near reproducible summation ! ITAG = 2001 ! IF (MPL_RANK == 1) THEN ! DO IPROC=2,MPL_NUMPROC ! CALL MPL_RECV(ZRECVBUF,KSOURCE=IPROC,KCOMM=ICOMM,KTAG=ITAG,& ! &KERROR=IERROR,KOUNT=ICOUNT) ! IF (ICOUNT /= ISENDCOUNT) THEN ! WRITE(MPL_ERRUNIT,'(A,I10,A,I6,A,I10)')& ! & 'MPL_ALLREDUCE: RECEIVED UNEXPECTED NUMBER OF ELEMENTS ', & ! & ICOUNT,' FROM PROC ',IPROC,'. EXPECTED=',ISENDCOUNT ! CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ! ENDIF ! PSENDBUF(:) = PSENDBUF(:) + ZRECVBUF(:) ! ENDDO ! ZRECVBUF(:) = PSENDBUF(:) ! ELSE ! CALL MPL_SEND(PSENDBUF,KDEST=1,KCOMM=ICOMM,KTAG=ITAG,KERROR=IERROR,& ! &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='MPLS_SEND') ! ENDIF ! ITAG = ITAG + 1 ! CALL MPL_BROADCAST(ZRECVBUF,KTAG=ITAG,KCOMM=ICOMM,KROOT=1,KERROR=IERROR) !ELSE IF ( MPL_NUMPROC > 1 ) & CALL MPI_ALLREDUCE(PSENDBUF,ZRECVBUF,ISENDCOUNT,INT(MPI_REAL4), & & IOPER,ICOMM,IERROR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_REAL4)) CALL MPL_RECVSTATS(ISENDCOUNT,INT(MPI_REAL4)) ENDIF !ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_ALLREDUCE ',ISENDCOUNT,ICOMM,IOPER ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_ALLREDUCE',CDSTRING,LDABORT=LLABORT) ENDIF IF ( MPL_NUMPROC > 1 ) & PSENDBUF(:,:) = ZRECVBUF(:,:) END SUBROUTINE MPL_ALLREDUCE_REAL4_2D END MODULE MPL_ALLREDUCE_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/ec_mpi_finalize.F900000664000175000017500000000334515157200431025615 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE EC_MPI_FINALIZE(KERROR,LDCALLFINITO,LDMEMINFO,CALLER) USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_COMM_WORLD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(OUT) :: KERROR LOGICAL, INTENT(IN) :: LDCALLFINITO LOGICAL, INTENT(IN) :: LDMEMINFO CHARACTER(LEN=*), INTENT(IN) :: CALLER LOGICAL :: LLINIT, LLFIN, LLNOTMPIWORLD INTEGER(KIND=JPIM) :: IERR, ICOMM INTEGER(KIND=JPIM) :: NCOMM_MEMINFO COMMON /cmn_meminfo/ NCOMM_MEMINFO #include "ec_meminfo.intfb.h" #include "dr_hook_end.intfb.h" KERROR = 0 IF (LDCALLFINITO) THEN !*** common MPI_Finalize() CALL MPI_INITIALIZED(LLINIT,IERR) IF (LLINIT .AND. IERR == 0) THEN CALL MPI_FINALIZED(LLFIN,IERR) IF (.NOT.LLFIN .AND. IERR == 0) THEN LLNOTMPIWORLD = (NCOMM_MEMINFO /= 0 .and. NCOMM_MEMINFO /= MPI_COMM_WORLD) IF (LLNOTMPIWORLD) THEN ICOMM = NCOMM_MEMINFO ELSE ICOMM = MPI_COMM_WORLD ENDIF IF( LDMEMINFO ) CALL EC_MEMINFO(-1,"ec_mpi_finalize:"//caller,ICOMM,KBARR=1,KIOTASK=-1,KCALL=1) CALL DR_HOOK_END() ! Make sure DrHook output is produced before MPI_Finalize (in case it fails) CALL MPI_BARRIER(ICOMM,IERR) IF (LLNOTMPIWORLD) THEN ! CALL MPI_COMM_FREE(NCOMM_MEMINFO,IERR) NCOMM_MEMINFO = 0 ENDIF CALL MPI_FINALIZE(KERROR) ENDIF ENDIF ENDIF END SUBROUTINE EC_MPI_FINALIZE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_arg_mod.F900000664000175000017500000001374015157200431024760 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ARG_MOD !**** MPL_GETARG : A substitute for GET_COMMAND_ARGUMENT (formerly GETARG) for MPL applications ! MPL_IARGC : A substitute for function COMMAND_ARGUMENT_COUNT (formerly IARGC) for MPL applications ! Purpose. ! -------- ! MPL-task#1 calls GET_COMMAND_ARGUMENT until COMMAND_ARGUMENT_COUNT() arguments read ! or until the argument is a terminating argument ! Then arguments are passed on to other processors ! If MPL has not been initialized, it will be done now. !** Interface. ! ---------- ! CALL MPL_GETARG(KARG, CDARG) ! Input required arguments : ! ------------------------- ! KARG - The argument number requested (INTEGER(4)) ! Range : [ 0 .. MPL_IARGC() ] ! Output required arguments : ! --------------------------- ! CDARG - Return argument value (CHARACTER(LEN=*)) ! !** Interface. ! ---------- ! INUM_ARGS = MPL_IARGC() ! ! where INUM_ARGS is INTEGER(4) ! Author. ! ------- ! S.Saarinen, G.Mozdzynski ECMWF ! Modifications. ! -------------- ! Original: 2006-03-15 USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_COMM_WORLD, MPI_BYTE, MPI_INTEGER USE MPL_DATA_MODULE, ONLY : MPL_NUMPROC,LINITMPI_VIA_MPL,LMPLUSERCOMM,MPLUSERCOMM IMPLICIT NONE PRIVATE CHARACTER(LEN=10), SAVE :: CL_TERMINATE = '-^' ! terminating argument INTEGER(KIND=JPIM), PARAMETER :: JP_ARGLEN = 1024 CHARACTER(LEN=JP_ARGLEN), ALLOCATABLE, SAVE :: CL_ARGS(:) INTEGER(KIND=JPIM), SAVE :: N_ARGS = -1 PUBLIC :: MPL_GETARG PUBLIC :: MPL_IARGC PUBLIC :: MPL_ARG_SET_CL_TERMINATE PUBLIC :: MPL_ARG_GET_CL_TERMINATE CONTAINS SUBROUTINE MPL_ARG_SET_CL_TERMINATE(CDTERM) CHARACTER(LEN=*), INTENT(IN) :: CDTERM CL_TERMINATE = CDTERM END SUBROUTINE MPL_ARG_SET_CL_TERMINATE SUBROUTINE MPL_ARG_GET_CL_TERMINATE(CDTERM) CHARACTER(LEN=*), INTENT(OUT) :: CDTERM CDTERM = CL_TERMINATE END SUBROUTINE MPL_ARG_GET_CL_TERMINATE SUBROUTINE INIT_ARGS() #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_INITIALIZED => MPI_INITIALIZED8, MPI_COMM_SIZE => MPI_COMM_SIZE8, & MPI_COMM_RANK => MPI_COMM_RANK8, MPI_BCAST => MPI_BCAST8, & MPI_INIT => MPI_INIT8 #endif INTEGER(KIND=JPIM) :: IARGS INTEGER(KIND=JPIM) :: IERROR, IROOT, ICOUNT INTEGER(KIND=JPIM) :: IRANK, INUMPROC, IRET, J INTEGER(KIND=JPIM) :: IARGC_C CHARACTER(LEN=LEN(CL_TERMINATE)) :: ENV_CL_TERMINATE CHARACTER(LEN=JP_ARGLEN) :: CLARG0 LOGICAL LLCARGS INTEGER LLINIT INTEGER(KIND=JPIM) :: ICOMM IF (N_ARGS == -1) THEN IF (MPL_NUMPROC == -1) THEN ! This is complicated, but I hope it works: ! MPI has not yet been initialized, when this routines was called. ! Initialize MPI, but NOT via MPL_INIT to avoid recursion in MPL_IARGC() ! However, must pretend that MPL_INIT has actually initialized it, but ! MPL_NUMPROC will not be set CALL MPI_INITIALIZED(LLINIT,IRET) IF (LLINIT == 0) THEN CALL MPI_INIT(IERROR) LINITMPI_VIA_MPL = .TRUE. CALL EC_MPI_ATEXIT() ! ifsaux/support/endian.c: to make sure MPI_FINALIZE gets called ENDIF ENDIF ! If LMPLUSERCOMM is not set use MPI_COMM_WORLD IF (LMPLUSERCOMM) THEN ICOMM = MPLUSERCOMM ELSE ICOMM = MPI_COMM_WORLD ENDIF CALL MPI_COMM_SIZE(ICOMM,INUMPROC,IERROR) CALL MPI_COMM_RANK(ICOMM,IRANK,IERROR) IRANK=IRANK+1 IF (IRANK == 1 .OR. INUMPROC == 1) THEN CALL GET_ENVIRONMENT_VARIABLE('MPL_CL_TERMINATE',ENV_CL_TERMINATE) IF (ENV_CL_TERMINATE /= ' ') CL_TERMINATE = ENV_CL_TERMINATE IARGS = COMMAND_ARGUMENT_COUNT() LLCARGS = (IARGS < 0) ! Should be true for non-F90 main programs IF (LLCARGS) THEN IARGS = IARGC_C() LLCARGS = (IARGS >= 0) CALL GETARG_C(0,CLARG0) ! The executable name (see ifsaux/support/cargs.c) ELSE CALL PUTARG_INFO(IARGS, TRIM(CL_TERMINATE)) ! (see ifsaux/support/cargs.c) CALL GET_COMMAND_ARGUMENT(0,CLARG0) ! The executable name (normal F2003 way) CALL PUTARG_C(0,TRIM(CLARG0)) ! (see ifsaux/support/cargs.c) ENDIF IF (IARGS < 0) IARGS = 0 ALLOCATE(CL_ARGS(0:IARGS)) N_ARGS = 0 CL_ARGS(0) = CLARG0 DO J=1,IARGS ! Other args (repeat until end of loop or terminating argument found) IF (LLCARGS) THEN CALL GETARG_C(J,CL_ARGS(J)) ELSE CALL GET_COMMAND_ARGUMENT(J,CL_ARGS(J)) CALL PUTARG_C(J,TRIM(CL_ARGS(J))) ENDIF IF (CL_ARGS(J) == CL_TERMINATE) EXIT N_ARGS = N_ARGS + 1 ENDDO ENDIF IF (INUMPROC > 1) THEN IROOT = 0 IARGS = 0 IF (IRANK == 1) IARGS = N_ARGS ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(IARGS,1,MPI_INTEGER,IROOT,ICOMM,IERROR) ICOUNT = JP_ARGLEN IF (IRANK > 1) ALLOCATE(CL_ARGS(0:IARGS)) IF (IRANK > 1) CALL PUTARG_INFO(IARGS, TRIM(CL_TERMINATE)) DO J=0,IARGS ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated CALL MPI_BCAST(CL_ARGS(J),ICOUNT,MPI_BYTE,IROOT,ICOMM,IERROR) IF (IRANK > 1) CALL PUTARG_C(J,TRIM(CL_ARGS(J))) ENDDO IF (IRANK > 1) N_ARGS = IARGS ENDIF ENDIF END SUBROUTINE INIT_ARGS SUBROUTINE MPL_GETARG(KARG, CDARG) INTEGER(KIND=JPIM), INTENT(IN) :: KARG CHARACTER(LEN=*), INTENT(OUT) :: CDARG IF (N_ARGS == -1) CALL INIT_ARGS() IF (KARG >= 0 .AND. KARG <= N_ARGS) THEN CDARG = CL_ARGS(KARG) ELSE CDARG = ' ' ENDIF END SUBROUTINE MPL_GETARG FUNCTION MPL_IARGC() RESULT(IRET) INTEGER(KIND=JPIM) :: IRET IF (N_ARGS == -1) CALL INIT_ARGS() IRET = N_ARGS END FUNCTION MPL_IARGC END MODULE MPL_ARG_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_scatterv_mod.F900000664000175000017500000002317615157200431026046 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_SCATTERV_MOD !**** MPL_SCATTERV Scatter data from specific processor ! Purpose. ! -------- ! Scatter data from specific processor ! The data may be REAL*8,or INTEGER, one dimensional array ! !** Interface. ! ---------- ! CALL MPL_SCATTERV ! Input required arguments : ! ------------------------- ! PRECVBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! PSENDBUF - buffer containing message ! (required from kroot) ! (can be type REAL*4, REAL*8 or INTEGER) ! KSENDCOUNTS-number of elements to be sent to each process ! (required from kroot processor) ! Input optional arguments : ! ------------------------- ! KROOT - rank of sending processor (default 1) ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! KSENDDISPL -displacements in PRECVBUF at which to place ! the incoming data ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_SCATTERV aborts when an error is detected. ! Author. ! ------- ! Y. Tremolet, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 02-03-13 ! M.Hamrud : 2014-10-22 : Add nonblocking option ! F. Vana 05-Mar-2015 Support for single precision ! --- *NOT* THREAD SAFE YET --- ! ---------------------------------------------------------------- USE EC_PARKIND, ONLY : JPRD, JPIM, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_INTEGER, MPI_REAL4, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_ERRUNIT, MPL_METHOD, MPL_NUMPROC, MPL_RANK, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_MYRANK_MOD, ONLY : MPL_MYRANK USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE PUBLIC MPL_SCATTERV INTEGER(KIND=JPIM) :: ICOMM,IROOT,IPL_NUMPROC,IRECVCOUNT,ISENDBUFSIZE,IR,IPL_MYRANK,IMP_TYPE LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: IERROR,IDUM REAL(KIND=JPRD) :: ZDUM REAL(KIND=JPRM) :: ZDUM_4 INTEGER(KIND=JPIM) :: ZDUM_INT INTERFACE MPL_SCATTERV MODULE PROCEDURE MPL_SCATTERV_REAL8,MPL_SCATTERV_REAL4,MPL_SCATTERV_INTEGER END INTERFACE CONTAINS SUBROUTINE MPL_SCATTERV_PREAMB1(KCOMM,KROOT,KMP_TYPE,KREQUEST) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8, MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KMP_TYPE INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KREQUEST INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IERROR = 0 IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SCATTERV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(CDMESSAGE='MPL_SCATTERV: KREQUEST MISSING',LDABORT=LLABORT) ENDIF IF(ICOMM == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC IPL_MYRANK = MPL_RANK ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) IPL_MYRANK = MPL_MYRANK(ICOMM) ENDIF IF(PRESENT(KROOT)) THEN IROOT=KROOT ELSE IROOT=1 ENDIF END SUBROUTINE MPL_SCATTERV_PREAMB1 SUBROUTINE MPL_SCATTERV_PREAMB2(KSENDCOUNTS,KISENDDISPL,KSENDDISPL,KISENDDISPL_PT,CDSTRING) INTEGER(KIND=JPIM),INTENT(IN) :: KSENDCOUNTS(:) INTEGER(KIND=JPIM),TARGET,INTENT(IN),OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM),ALLOCATABLE,TARGET,INTENT(OUT) :: KISENDDISPL(:) INTEGER(KIND=JPIM),POINTER,INTENT(OUT),OPTIONAL :: KISENDDISPL_PT(:) CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING IF(SIZE(KSENDCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_SCATTERV: ERROR KSENDCOUNTS DIMENSION=',& & SIZE(KSENDCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_SCATTERV: ERROR KSENDCOUNTS DIMENSION IS WRONG',LDABORT=LLABORT) ENDIF IF(IRECVCOUNT /= KSENDCOUNTS(IPL_MYRANK)) THEN WRITE(MPL_ERRUNIT,*)'MPL_SCATTERV: ERROR KSENDCOUNTS INCONSISTENCY ',& & IRECVCOUNT,KSENDCOUNTS(IPL_MYRANK) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_SCATTERV: ERROR IRECVCOUNT /= KSENDCOUNTS(MPL_RANK) ',LDABORT=LLABORT) ENDIF IF(PRESENT(KSENDDISPL)) THEN KISENDDISPL_PT => KSENDDISPL(:) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC,KRECV_PT=KISENDDISPL_PT) ELSE ALLOCATE(KISENDDISPL(IPL_NUMPROC)) KISENDDISPL_PT => KISENDDISPL END IF KISENDDISPL_PT(1) = 0 DO IR=2, IPL_NUMPROC KISENDDISPL_PT(IR) = KISENDDISPL_PT(IR-1) + KSENDCOUNTS(IR-1) ENDDO ENDIF DO IR=1, IPL_NUMPROC IF(KISENDDISPL_PT(IR)+KSENDCOUNTS(IR) > ISENDBUFSIZE) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_SCATTERV:SEND BUFFER TOO SMALL ', & & IR,KISENDDISPL_PT(IR),KSENDCOUNTS(IR),ISENDBUFSIZE CALL MPL_MESSAGE(CDMESSAGE='MPL_SCATTERV',CDSTRING=CDSTRING,LDABORT=LLABORT) ENDIF ENDDO END SUBROUTINE MPL_SCATTERV_PREAMB2 ! ------------------------------------------------------------------ SUBROUTINE MPL_SCATTERV_REAL8(PRECVBUF,KROOT,PSENDBUF,KSENDCOUNTS,KSENDDISPL,& & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8 #endif REAL(KIND=JPRD), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT REAL(KIND=JPRD), INTENT(IN),OPTIONAL :: PSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN),TARGET,OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: ISENDDISPL(:) INTEGER(KIND=JPIM),POINTER :: ISENDDISPL_PT(:) INTEGER IDATA_TYPE LOGICAL LLPRESENT_SENDBUF IDATA_TYPE=INT(MPI_REAL8) LLPRESENT_SENDBUF=PRESENT(PSENDBUF) #include "mpl_scatterv_array_tmpl.i90" END SUBROUTINE MPL_SCATTERV_REAL8 ! ------------------------------------------------------------------ SUBROUTINE MPL_SCATTERV_REAL4(PRECVBUF,KROOT,PSENDBUF,KSENDCOUNTS,KSENDDISPL,& & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8 #endif REAL(KIND=JPRM), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT REAL(KIND=JPRM), INTENT(IN),OPTIONAL :: PSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN),TARGET,OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: ISENDDISPL(:) INTEGER(KIND=JPIM),POINTER :: ISENDDISPL_PT(:) INTEGER IDATA_TYPE LOGICAL LLPRESENT_SENDBUF IDATA_TYPE=INT(MPI_REAL4) LLPRESENT_SENDBUF=PRESENT(PSENDBUF) #include "mpl_scatterv_array_tmpl.i90" END SUBROUTINE MPL_SCATTERV_REAL4 SUBROUTINE MPL_SCATTERV_INTEGER(KRECVBUF,KROOT,KSENDBUF,KSENDCOUNTS,& & KSENDDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SCATTERV => MPI_SCATTERV8 #endif INTEGER(KIND=JPIM), INTENT(OUT) :: KRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN) :: KROOT INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KSENDCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN),TARGET,OPTIONAL :: KSENDDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),ALLOCATABLE :: ISENDDISPL(:) INTEGER(KIND=JPIM),POINTER :: ISENDDISPL_PT(:) INTEGER IDATA_TYPE LOGICAL LLPRESENT_SENDBUF IDATA_TYPE=INT(MPI_INTEGER) LLPRESENT_SENDBUF=PRESENT(KSENDBUF) IF (PRESENT(KSENDBUF)) THEN ASSOCIATE(PRECVBUF=>KRECVBUF, PSENDBUF=>KSENDBUF) #include "mpl_scatterv_array_tmpl.i90" END ASSOCIATE ELSE ASSOCIATE(PRECVBUF=>KRECVBUF, PSENDBUF=>KRECVBUF) #include "mpl_scatterv_array_tmpl.i90" END ASSOCIATE END IF END SUBROUTINE MPL_SCATTERV_INTEGER ! ------------------------------------------------------------------ END MODULE MPL_SCATTERV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpi4to8_m.F900000664000175000017500000025365215157200431024330 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPI4TO8_M #ifdef USE_8_BYTE_WORDS USE EC_PARKIND, ONLY : JPIM, JPRM, JPRD USE MPL_MPIF IMPLICIT NONE PRIVATE :: STATUS8 INTEGER(KIND=8), DIMENSION(MPI_STATUS_SIZE) :: STATUS8 INTERFACE MPI_ALLGATHERV8 MODULE PROCEDURE MPI_ALLGATHERV8_R4, MPI_ALLGATHERV8_R8, & MPI_ALLGATHERV8_I4, MPI_ALLGATHERV8_I1 END INTERFACE MPI_ALLGATHERV8 INTERFACE MPI_ALLREDUCE8 MODULE PROCEDURE MPI_ALLREDUCE8_R4, MPI_ALLREDUCE8_R8, & MPI_ALLREDUCE8_I4, MPI_ALLREDUCE8_R4_2D, & MPI_ALLREDUCE8_R8_2D END INTERFACE MPI_ALLREDUCE8 INTERFACE MPI_ALLTOALLV8 MODULE PROCEDURE MPI_ALLTOALLV8_R8, MPI_ALLTOALLV8_I4 END INTERFACE MPI_ALLTOALLV8 INTERFACE MPI_BCAST8 MODULE PROCEDURE MPI_BCAST8_R4, MPI_BCAST8_R8, & MPI_BCAST8_I4, MPI_BCAST8_I1, & MPI_BCAST8_CH END INTERFACE MPI_BCAST8 INTERFACE MPI_BSEND8 MODULE PROCEDURE MPI_BSEND8_R4, MPI_BSEND8_R8, & MPI_BSEND8_R42, MPI_BSEND8_R82, & MPI_BSEND8_I4, MPI_BSEND8_I1, & MPI_BSEND8_CH, MPI_BSEND8_I42, & MPI_BSEND8_R4_1, MPI_BSEND8_R8_1 END INTERFACE MPI_BSEND8 INTERFACE MPI_ISEND8 MODULE PROCEDURE MPI_ISEND8_R4, MPI_ISEND8_R8, & MPI_ISEND8_R42, MPI_ISEND8_R82, & MPI_ISEND8_I4, MPI_ISEND8_I1, & MPI_ISEND8_CH, MPI_ISEND8_I42, & MPI_ISEND8_R4_1, MPI_ISEND8_R8_1 END INTERFACE MPI_ISEND8 INTERFACE MPI_SEND8 MODULE PROCEDURE MPI_SEND8_R4, MPI_SEND8_R8, & MPI_SEND8_R42, MPI_SEND8_R82, & MPI_SEND8_I4, MPI_SEND8_I1, & MPI_SEND8_CH, MPI_SEND8_I42, & MPI_SEND8_R4_1, MPI_SEND8_R8_1 END INTERFACE MPI_SEND8 INTERFACE MPI_FILE_IREAD_SHARED8 MODULE PROCEDURE MPI_FILE_IREAD_SHARED8_R8, MPI_FILE_IREAD_SHARED8_I4 END INTERFACE MPI_FILE_IREAD_SHARED8 INTERFACE MPI_FILE_IWRITE_SHARED8 MODULE PROCEDURE MPI_FILE_IWRITE_SHARED8_R8, MPI_FILE_IWRITE_SHARED8_I4 END INTERFACE MPI_FILE_IWRITE_SHARED8 INTERFACE MPI_FILE_READ_ORDERED8 MODULE PROCEDURE MPI_FILE_READ_ORDERED8_R8, MPI_FILE_READ_ORDERED8_I4 END INTERFACE MPI_FILE_READ_ORDERED8 INTERFACE MPI_FILE_READ_ORDERED_BEGIN8 MODULE PROCEDURE MPI_FREAD_ORDERED_BEGIN8_R8, MPI_FREAD_ORDERED_BEGIN8_I4 END INTERFACE MPI_FILE_READ_ORDERED_BEGIN8 INTERFACE MPI_FILE_READ_ORDERED_END8 MODULE PROCEDURE MPI_FREAD_ORDERED_END8_R8, MPI_FREAD_ORDERED_END8_I4 END INTERFACE MPI_FILE_READ_ORDERED_END8 INTERFACE MPI_FILE_READ_SHARED8 MODULE PROCEDURE MPI_FILE_READ_SHARED8_R8, MPI_FILE_READ_SHARED8_I4 END INTERFACE MPI_FILE_READ_SHARED8 INTERFACE MPI_FILE_WRITE_ORDERED8 MODULE PROCEDURE MPI_FILE_WRITE_ORDERED8_R8, MPI_FILE_WRITE_ORDERED8_I4 END INTERFACE MPI_FILE_WRITE_ORDERED8 INTERFACE MPI_FILE_WRITE_ORDERED_BEGIN8 MODULE PROCEDURE MPI_FWRITE_ORDERED_BEGIN8_R8, MPI_FWRITE_ORDERED_BEGIN8_I4 END INTERFACE MPI_FILE_WRITE_ORDERED_BEGIN8 INTERFACE MPI_FILE_WRITE_ORDERED_END8 MODULE PROCEDURE MPI_FWRITE_ORDERED_END8_R8, MPI_FWRITE_ORDERED_END8_I4 END INTERFACE MPI_FILE_WRITE_ORDERED_END8 INTERFACE MPI_FILE_WRITE_SHARED8 MODULE PROCEDURE MPI_FILE_WRITE_SHARED8_R8, MPI_FILE_WRITE_SHARED8_I4 END INTERFACE MPI_FILE_WRITE_SHARED8 INTERFACE MPI_GATHER8 MODULE PROCEDURE MPI_GATHER8_I1, MPI_GATHER8_R8_1 END INTERFACE MPI_GATHER8 INTERFACE MPI_GATHERV8 MODULE PROCEDURE MPI_GATHERV8_R4, MPI_GATHERV8_R8, & MPI_GATHERV8_R4S, MPI_GATHERV8_R8S, & MPI_GATHERV8_I4, MPI_GATHERV8_I1, & MPI_GATHERV8_I4S, MPI_GATHERV8_I4S_1, & MPI_GATHERV8_R8_1, MPI_GATHERV8_R8S_1 END INTERFACE MPI_GATHERV8 INTERFACE MPI_RECV8 MODULE PROCEDURE MPI_RECV8_R4, MPI_RECV8_R8, & MPI_RECV8_R42, MPI_RECV8_R82, & MPI_RECV8_I4, MPI_RECV8_I1, & MPI_RECV8_R4_1, MPI_RECV8_R8_1, & MPI_RECV8_CH, MPI_RECV8_I42 END INTERFACE MPI_RECV8 INTERFACE MPI_IRECV8 MODULE PROCEDURE MPI_IRECV8_R4, MPI_IRECV8_R8, & MPI_IRECV8_R42, MPI_IRECV8_R82, & MPI_IRECV8_I4, MPI_IRECV8_I1, & MPI_IRECV8_I42, & MPI_IRECV8_R4_1, MPI_IRECV8_R8_1, & MPI_IRECV8_CH END INTERFACE MPI_IRECV8 INTERFACE MPI_SCATTERV8 MODULE PROCEDURE MPI_SCATTERV8_R8, MPI_SCATTERV8_I4, & MPI_SCATTERV8_R8S, MPI_SCATTERV8_I4S END INTERFACE MPI_SCATTERV8 PUBLIC CONTAINS ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ALLREDUCE8_R4(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDDATA(:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & RECVDATA(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVDATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDDATA8 = SENDDATA COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA8, RECVDATA8, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_ALLREDUCE8_R4 SUBROUTINE MPI_ALLREDUCE8_R4_2D(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & SENDDATA(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRM), DIMENSION(:,:), INTENT(OUT) :: & RECVDATA(:.:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & SENDDATA8, RECVDATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDDATA8 = SENDDATA COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA8, RECVDATA8, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_ALLREDUCE8_R4_2D ! --------------------------------------------------------- SUBROUTINE MPI_ALLREDUCE8_R8(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDDATA(:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVDATA(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA, RECVDATA, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_ALLREDUCE8_R8 SUBROUTINE MPI_ALLREDUCE8_R8_2D(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & SENDDATA(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM REAL(KIND=JPRD), DIMENSION(:,:), INTENT(OUT) :: & RECVDATA(:,:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA, RECVDATA, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_ALLREDUCE8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ALLREDUCE8_I4(SENDDATA, RECVDATA, COUNT, DATATYPE, OP, & COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDDATA(:) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, OP, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVDATA(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVDATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, OP8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDDATA8 = SENDDATA COUNT8 = COUNT DATATYPE8 = DATATYPE OP8 = OP COMM8 = COMM CALL MPI_ALLREDUCE(SENDDATA8, RECVDATA8, COUNT8, DATATYPE8, OP8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_ALLREDUCE8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_R4(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, RECVAREA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDAREA8 = SENDAREA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_R8(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_I4(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDAREA, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDAREA8 = SENDAREA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_ALLGATHERV8_I1(SENDAREA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDAREA8 = SENDAREA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLGATHERV(SENDAREA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_ALLGATHERV8_I1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ALLTOALLV8_R8(SENDAREA, SENDCOUNTS, SDISPLS, SENDTYPE, & RECVAREA, RECVCOUNTS, RDISPLS, RECVTYPE, & COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDCOUNTS, SDISPLS, RECVCOUNTS, RDISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVTYPE, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDCOUNTS8, SDISPLS8, RECVCOUNTS8, RDISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(SDISPLS8(SIZE(SDISPLS))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(RDISPLS8(SIZE(RDISPLS))) SENDCOUNTS8 = SENDCOUNTS SDISPLS8 = SDISPLS SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS RDISPLS8 = RDISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLTOALLV(SENDAREA, SENDCOUNTS8, SDISPLS8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, RDISPLS8, RECVTYPE8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(SENDCOUNTS8) DEALLOCATE(SDISPLS8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(RDISPLS8) END SUBROUTINE MPI_ALLTOALLV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ALLTOALLV8_I4(SENDAREA, SENDCOUNTS, SDISPLS, SENDTYPE, & RECVAREA, RECVCOUNTS, RDISPLS, RECVTYPE, & COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDAREA, SENDCOUNTS, SDISPLS, RECVCOUNTS, RDISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVTYPE, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, SENDCOUNTS8, SDISPLS8, RECVAREA8, RECVCOUNTS8, RDISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVTYPE8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(SDISPLS8(SIZE(SDISPLS))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(RDISPLS8(SIZE(RDISPLS))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS SDISPLS8 = SDISPLS SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS RDISPLS8 = RDISPLS RECVTYPE8 = RECVTYPE COMM8 = COMM CALL MPI_ALLTOALLV(SENDAREA8, SENDCOUNTS8, SDISPLS8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, RDISPLS8, RECVTYPE8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(SENDCOUNTS8) DEALLOCATE(SDISPLS8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(RDISPLS8) END SUBROUTINE MPI_ALLTOALLV8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_R4(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) DATA = DATA8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BCAST8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_R8(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BCAST8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_I4(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) DATA = DATA8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BCAST8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_I1(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA8, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) DATA = DATA8 IERROR = IERROR8 END SUBROUTINE MPI_BCAST8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_BCAST8_CH(DATA, COUNT, DATATYPE, ROOT, COMM, IERROR) CHARACTER(LEN=*), INTENT(INOUT) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_BCAST(DATA, COUNT8, DATATYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BCAST8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_R4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R8(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_R42 ! ========================================================= SUBROUTINE MPI_BSEND8_I42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_I42 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_R82(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R82 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_I4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_BSEND8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_I1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_I1 ! ========================================================= SUBROUTINE MPI_BSEND8_R4_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R4_1 ! ========================================================= SUBROUTINE MPI_BSEND8_R8_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_R8_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_BSEND8_CH(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) CHARACTER(LEN=*), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_BSEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_BSEND8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_R4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R8(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_R42 ! ========================================================= SUBROUTINE MPI_ISEND8_I42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_I42 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_R82(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R82 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_I4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_ISEND8_I4 ! ========================================================= SUBROUTINE MPI_ISEND8_R4_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8):: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R4_1 ! ========================================================= SUBROUTINE MPI_ISEND8_R8_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8) :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_R8_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_I1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_I1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_ISEND8_CH(DATA, COUNT, DATATYPE, DEST, TAG, COMM, REQUEST, IERROR) CHARACTER(LEN=*), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_ISEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_ISEND8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_R4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R8(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_R42 ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_I42(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_I42 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_R82(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:,:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R82 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_I4(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_SEND8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_I1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_I1 ! ========================================================= SUBROUTINE MPI_SEND8_R4_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRM), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R4_1 ! ========================================================= SUBROUTINE MPI_SEND8_R8_1(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8) :: DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 DATA8 = DATA COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA8, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_R8_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SEND8_CH(DATA, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) CHARACTER(LEN=*), INTENT(IN) :: & DATA INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, DEST, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE DEST8 = DEST TAG8 = TAG COMM8 = COMM CALL MPI_SEND(DATA, COUNT8, DATATYPE8, DEST8, TAG8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_SEND8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IREAD_SHARED8_R8(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IREAD_SHARED(FH8, BUF, COUNT8, DATATYPE8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_IREAD_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IREAD_SHARED8_I4(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IREAD_SHARED(FH8, BUF8, COUNT8, DATATYPE8, REQUEST8, IERROR8) BUF = BUF8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_IREAD_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IWRITE_SHARED8_R8(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & BUF INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IWRITE_SHARED(FH8, BUF, COUNT8, DATATYPE8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_IWRITE_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_IWRITE_SHARED8_I4(FH, BUF, COUNT, DATATYPE, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, BUF(:), COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, REQUEST8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH BUF8 = BUF COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_IWRITE_SHARED(FH8, BUF8, COUNT8, DATATYPE8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_IWRITE_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_ORDERED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_READ_ORDERED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_ORDERED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) BUF = BUF8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_READ_ORDERED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_R8(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED_BEGIN(FH8, BUF, COUNT8, DATATYPE8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_I4(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_ORDERED_BEGIN(FH8, BUF8, COUNT8, DATATYPE8, IERROR8) BUF = BUF8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FREAD_ORDERED_BEGIN8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_END8_R8(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, IERROR8 FH8 = FH CALL MPI_FILE_READ_ORDERED_END(FH8, BUF, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FREAD_ORDERED_END8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FREAD_ORDERED_END8_I4(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH CALL MPI_FILE_READ_ORDERED_END(FH8, BUF8, STATUS8, IERROR8) BUF = BUF8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FREAD_ORDERED_END8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_SHARED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_SHARED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_READ_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_READ_SHARED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_READ_SHARED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) BUF = BUF8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_READ_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_ORDERED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & BUF INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_WRITE_ORDERED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_ORDERED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, BUF(:), COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH BUF8 = BUF COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_WRITE_ORDERED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_R8(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED_BEGIN(FH8, BUF, COUNT8, DATATYPE8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_I4(FH, BUF, COUNT, DATATYPE, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_ORDERED_BEGIN(FH8, BUF8, COUNT8, DATATYPE8, IERROR8) BUF = BUF8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FWRITE_ORDERED_BEGIN8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_END8_R8(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, STATUS(:) REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & BUF INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & FH8, IERROR8 FH8 = FH STATUS8 = STATUS CALL MPI_FILE_WRITE_ORDERED_END(FH8, BUF, STATUS8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_FWRITE_ORDERED_END8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FWRITE_ORDERED_END8_I4(FH, BUF, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, STATUS(:) INTEGER(KIND=JPIM), INTENT(OUT) :: & BUF(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH STATUS8 = STATUS CALL MPI_FILE_WRITE_ORDERED_END(FH8, BUF8, STATUS8, IERROR8) BUF = BUF8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FWRITE_ORDERED_END8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_SHARED8_R8(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & BUF INTEGER(KIND=JPIM), INTENT(IN) :: & FH, COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 FH8 = FH COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_SHARED(FH8, BUF, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_FILE_WRITE_SHARED8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_FILE_WRITE_SHARED8_I4(FH, BUF, COUNT, DATATYPE, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & FH, BUF(:), COUNT, DATATYPE INTEGER(KIND=JPIM), INTENT(OUT) :: & STATUS(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & BUF8 INTEGER(KIND=8) :: & FH8, COUNT8, DATATYPE8, IERROR8 ALLOCATE(BUF8(SIZE(BUF))) FH8 = FH BUF8 = BUF COUNT8 = COUNT DATATYPE8 = DATATYPE CALL MPI_FILE_WRITE_SHARED(FH8, BUF8, COUNT8, DATATYPE8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(BUF8) END SUBROUTINE MPI_FILE_WRITE_SHARED8_I4 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_GATHER8_R8_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHER(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_GATHER8_R8_1 ! --------------------------------------------------------- SUBROUTINE MPI_GATHER8_I1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDDATA, SENDCOUNT, SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8) :: & SENDDATA8, RECVAREA8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHER(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 END SUBROUTINE MPI_GATHER8_I1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R8(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R8S(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_GATHERV8_R8S ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R4(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVAREA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R4S(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRM), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRM), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8 REAL(KIND=8) :: RECVAREA8 INTEGER(KIND=8) :: RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) END SUBROUTINE MPI_GATHERV8_R4S ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I4(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDDATA, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA(:), IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8, RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) ALLOCATE(RECVAREA8(SIZE(RECVAREA))) ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) DEALLOCATE(RECVAREA8) DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I4S(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDDATA8 INTEGER(KIND=8) :: & RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDDATA8(SIZE(SENDDATA))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(SENDDATA8) END SUBROUTINE MPI_GATHERV8_I4S ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I4S_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM, RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8) :: & SENDDATA8 INTEGER(KIND=8) :: & RECVAREA8, RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 END SUBROUTINE MPI_GATHERV8_I4S_1 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_I1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDDATA, SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & RECVAREA, IERROR INTEGER(KIND=8) :: & SENDDATA8, RECVAREA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDDATA8 = SENDDATA SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA8, SENDCOUNT8, SENDTYPE8, RECVAREA8, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVAREA = RECVAREA8 IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_GATHERV8_R8_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVCOUNTS8(SIZE(RECVCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 DEALLOCATE(RECVCOUNTS8) DEALLOCATE(DISPLS8) END SUBROUTINE MPI_GATHERV8_R8_1 ! ========================================================= SUBROUTINE MPI_GATHERV8_R8S_1(SENDDATA, SENDCOUNT, SENDTYPE, RECVAREA, & RECVCOUNTS, DISPLS, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDDATA INTEGER(KIND=JPIM), INTENT(IN) :: & RECVCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDCOUNT, SENDTYPE, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), INTENT(OUT) :: & RECVAREA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & RECVCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDCOUNT8, SENDTYPE8, RECVTYPE8, ROOT8, COMM8, IERROR8 SENDCOUNT8 = SENDCOUNT SENDTYPE8 = SENDTYPE RECVCOUNTS8 = RECVCOUNTS DISPLS8 = DISPLS RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_GATHERV(SENDDATA, SENDCOUNT8, SENDTYPE8, RECVAREA, & RECVCOUNTS8, DISPLS8, RECVTYPE8, ROOT8, COMM8, IERROR8) IERROR = IERROR8 END SUBROUTINE MPI_GATHERV8_R8S_1 ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R8(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_R42 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_I42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_I42 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R82(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R82 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_I4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & DATA, STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_RECV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_I1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS INTEGER(KIND=JPIM), INTENT(OUT) :: & DATA, IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R4_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS REAL(KIND=JPRM), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8) :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) DATA = DATA8 STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R4_1 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_R8_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS REAL(KIND=JPRD), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_R8_1 ! --------------------------------------------------------- SUBROUTINE MPI_RECV8_CH(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & STATUS CHARACTER(LEN=*), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_RECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, STATUS8, IERROR8) STATUS = STATUS8 IERROR = IERROR8 END SUBROUTINE MPI_RECV8_CH ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_R4 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R8(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_R42 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R82(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R82 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_I4(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & DATA(:), REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_I4 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_I42(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), DIMENSION(:,:), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8), DIMENSION(:,:), ALLOCATABLE :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 ALLOCATE(DATA8(SIZE(DATA,DIM=1),SIZE(DATA,DIM=2))) COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 DEALLOCATE(DATA8) END SUBROUTINE MPI_IRECV8_I42 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_I1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM INTEGER(KIND=JPIM), INTENT(OUT) :: & DATA, REQUEST, IERROR INTEGER(KIND=8) :: & DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_I1 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R4_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRM), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR REAL(KIND=8) :: & DATA8 INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA8, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) DATA = DATA8 REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R4_1 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_R8_1(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM REAL(KIND=JPRD), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_R8_1 ! --------------------------------------------------------- SUBROUTINE MPI_IRECV8_CH(DATA, COUNT, DATATYPE, SOURCE, TAG, COMM, REQUEST, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & COUNT, DATATYPE, SOURCE, TAG, COMM CHARACTER(LEN=*), INTENT(OUT) :: & DATA INTEGER(KIND=JPIM), INTENT(OUT) :: & REQUEST, IERROR INTEGER(KIND=8) :: & COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8 COUNT8 = COUNT DATATYPE8 = DATATYPE SOURCE8 = SOURCE TAG8 = TAG COMM8 = COMM CALL MPI_IRECV(DATA, COUNT8, DATATYPE8, SOURCE8, TAG8, COMM8, REQUEST8, IERROR8) REQUEST = REQUEST8 IERROR = IERROR8 END SUBROUTINE MPI_IRECV8_CH ! ========================================================= ! --------------------------------------------------------- SUBROUTINE MPI_SCATTERV8_R8(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), DIMENSION(:), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, RECVDATA8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(SENDCOUNTS8) DEALLOCATE(DISPLS8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_R8 ! --------------------------------------------------------- SUBROUTINE MPI_SCATTERV8_R8S(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) REAL(KIND=JPRD), INTENT(IN) :: & SENDAREA INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM, SENDCOUNTS, DISPLS REAL(KIND=JPRD), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVDATA8 REAL(KIND=8) :: & SENDAREA8 INTEGER(KIND=8) :: & SENDCOUNTS8, DISPLS8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_R8S ! --------------------------------------------------------- SUBROUTINE MPI_SCATTERV8_I4(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), DIMENSION(:), INTENT(IN) :: & SENDAREA, SENDCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & SENDAREA8, SENDCOUNTS8, DISPLS8, RECVDATA8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(SENDAREA8(SIZE(SENDAREA))) ALLOCATE(SENDCOUNTS8(SIZE(SENDCOUNTS))) ALLOCATE(DISPLS8(SIZE(DISPLS))) ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(SENDAREA8) DEALLOCATE(SENDCOUNTS8) DEALLOCATE(DISPLS8) DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_I4 ! ========================================================= SUBROUTINE MPI_SCATTERV8_I4S(SENDAREA, SENDCOUNTS, DISPLS, SENDTYPE, & RECVDATA, RECVCOUNT, RECVTYPE, ROOT, COMM, IERROR) INTEGER(KIND=JPIM), INTENT(IN) :: & SENDAREA, SENDCOUNTS, DISPLS INTEGER(KIND=JPIM), INTENT(IN) :: & SENDTYPE, RECVCOUNT, RECVTYPE, ROOT, COMM INTEGER(KIND=JPIM), DIMENSION(:), INTENT(OUT) :: & RECVDATA INTEGER(KIND=JPIM), INTENT(OUT) :: & IERROR INTEGER(KIND=8) :: & SENDAREA8, SENDCOUNTS8, DISPLS8 INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: & RECVDATA8 INTEGER(KIND=8) :: & SENDTYPE8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8 ALLOCATE(RECVDATA8(SIZE(RECVDATA))) SENDAREA8 = SENDAREA SENDCOUNTS8 = SENDCOUNTS DISPLS8 = DISPLS SENDTYPE8 = SENDTYPE RECVCOUNT8 = RECVCOUNT RECVTYPE8 = RECVTYPE ROOT8 = ROOT COMM8 = COMM CALL MPI_SCATTERV(SENDAREA8, SENDCOUNTS8, DISPLS8, SENDTYPE8, & RECVDATA8, RECVCOUNT8, RECVTYPE8, ROOT8, COMM8, IERROR8) RECVDATA = RECVDATA8 IERROR = IERROR8 DEALLOCATE(RECVDATA8) END SUBROUTINE MPI_SCATTERV8_I4S ! ========================================================= ! ========================================================= ! ========================================================= #endif END MODULE MPI4TO8_M fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_mpi.F900000664000175000017500000000071715157200431024135 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MPI #include "mpif.h" END MODULE fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_alltoallv_mod.F900000664000175000017500000004210515157200431026176 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_ALLTOALLV_MOD !**** MPL_ALLTOALLV - Everyone sends different data to everyone ! Purpose. ! -------- ! Interface to MPI_ALLTOALLV ! The data may be REAL*8,or INTEGER !** Interface. ! ---------- ! CALL MPL_ALLTOALLV ! Input required arguments : ! ------------------------- ! PSENDBUF - buffer containing message ! (can be type REAL*8 or INTEGER) ! PRECVBUF - buffer containing message ! (can be type REAL*8 or INTEGER) ! KRECVCOUNTS-number of elements received from each process ! KSENDCOUNTS-number of elements to be sent to each process ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KRECVDISPL -displacements in PRECVBUF at which to place ! the incoming data ! KSENDDISPL -displacements in PSENDBUF from which to send ! the data ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_ALLTOALLV aborts when an error is detected. ! Author. ! ------- ! Y. Tremolet ! Modifications. ! -------------- ! Original: 02-03-21 ! Modified : 25-09-02 M.Hamrud - generalize ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_INTEGER, MPI_REAL4, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_ERRUNIT, MPL_METHOD, MPL_NUMPROC, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_STATS_MOD, ONLY : MPL_RECVSTATS, MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS USE MPL_DISPLS_CONTAINER_MOD, ONLY : YDDISPLS_LIST IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ICOMM,IERROR,IPL_NUMPROC,IRECVCOUNT,ISENDCOUNT,IR,IMP_TYPE LOGICAL :: LLSCALAR INTERFACE MPL_ALLTOALLV MODULE PROCEDURE MPL_ALLTOALLV_REAL8,MPL_ALLTOALLV_INTEGER,MPL_ALLTOALLV_REAL4 END INTERFACE PUBLIC MPL_ALLTOALLV CONTAINS ! ------------------------------------------------------------------ SUBROUTINE MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,KISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,KIRECVDISPL,KIRECVDISPL_PT, & KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SIZE => MPI_COMM_SIZE8 #endif IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRECVCOUNTS(:),KSENDCOUNTS(:) INTEGER(KIND=JPIM),TARGET,INTENT(OUT) :: KISENDDISPL(:),KIRECVDISPL(:) INTEGER(KIND=JPIM),POINTER,INTENT(OUT) :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KSENDDISPL(:),KRECVDISPL(:),KCOMM,KMP_TYPE,KREQUEST CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING TARGET :: KSENDDISPL,KRECVDISPL INTEGER(KIND=JPIM) :: ITID,J ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_ALLTOALLV: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(ICOMM == MPL_COMM_OML(ITID)) THEN IPL_NUMPROC = MPL_NUMPROC ELSE CALL MPI_COMM_SIZE(ICOMM,IPL_NUMPROC,IERROR) ENDIF IF(SIZE(KRECVCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_ALLTOALLV: ERROR KRECVCOUNTS dimension=',& & SIZE(KRECVCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_ALLTOALLV: ERROR KRECVCOUNTS dimension is wrong',LDABORT=LLABORT) ENDIF IF(SIZE(KSENDCOUNTS) < IPL_NUMPROC) THEN WRITE(MPL_ERRUNIT,*)'MPL_ALLTOALLV: ERROR KSENDCOUNTS dimension=',& & SIZE(KSENDCOUNTS) CALL MPL_MESSAGE(CDMESSAGE=& & 'MPL_ALLTOALLV: ERROR KSENDCOUNTS dimension is wrong',LDABORT=LLABORT) ENDIF IF(PRESENT(KRECVDISPL)) THEN KIRECVDISPL_PT => KRECVDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KNPROC=IPL_NUMPROC,KRECV_PT=KIRECVDISPL_PT) ELSE KIRECVDISPL_PT => KIRECVDISPL ENDIF KIRECVDISPL_PT(:) = 0 IF(LLSCALAR) THEN DO IR=2, IPL_NUMPROC KIRECVDISPL_PT(IR) = KIRECVDISPL_PT(IR-1) + 1 ENDDO ELSE DO IR=2, IPL_NUMPROC KIRECVDISPL_PT(IR) = KIRECVDISPL_PT(IR-1) + KRECVCOUNTS(IR-1) ENDDO ENDIF ENDIF DO IR=1, IPL_NUMPROC IF(KIRECVDISPL_PT(IR) < 0 .OR. KRECVCOUNTS(IR) < 0) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV: RECV.. < 0 ',& & IR,KIRECVDISPL_PT(IR),KRECVCOUNTS(IR) CALL MPL_MESSAGE(IERROR,'MPL_ALLTOALLV',CDSTRING,LDABORT=LLABORT) ENDIF IF(KIRECVDISPL_PT(IR)+KRECVCOUNTS(IR) > IRECVCOUNT) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV:RECV BUFFER TOO SMALL ', & & IR,KIRECVDISPL_PT(IR),KRECVCOUNTS(IR),IRECVCOUNT CALL MPL_MESSAGE(IERROR,'MPL_ALLTOALLV',CDSTRING,LDABORT=LLABORT) ENDIF ENDDO IF(PRESENT(KSENDDISPL)) THEN KISENDDISPL_PT => KSENDDISPL ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL YDDISPLS_LIST%APPEND(KSEND_PT = KISENDDISPL_PT,NO_NEW_NODE=.TRUE.) ELSE KISENDDISPL_PT => KISENDDISPL ENDIF KISENDDISPL_PT(:) = 0 IF(LLSCALAR) THEN DO IR=2, IPL_NUMPROC KISENDDISPL_PT(IR) = KISENDDISPL_PT(IR-1) + 1 ENDDO ELSE DO IR=2, IPL_NUMPROC KISENDDISPL_PT(IR) = KISENDDISPL_PT(IR-1) + KSENDCOUNTS(IR-1) ENDDO ENDIF ENDIF DO IR=1,IPL_NUMPROC IF(KISENDDISPL_PT(IR) < 0 .OR. KSENDCOUNTS(IR) < 0) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV:SEND.. <0 ',& & IR,KISENDDISPL_PT(IR),KSENDCOUNTS(IR) CALL MPL_MESSAGE(IERROR,'MPL_ALLTOALLV',CDSTRING,LDABORT=LLABORT) ENDIF IF(KISENDDISPL_PT(IR)+KSENDCOUNTS(IR) > ISENDCOUNT) THEN WRITE(MPL_ERRUNIT,'(A,4I10)')'MPL_ALLTOALLV:SEND BUFFER TOO SMALL ', & & IR,KISENDDISPL_PT(IR),KSENDCOUNTS(IR),ISENDCOUNT CALL MPL_MESSAGE(IERROR,'MPL_ALLTOALLV',CDSTRING,LDABORT=LLABORT) ENDIF ENDDO END SUBROUTINE MPL_ALLTOALLV_PREAMB SUBROUTINE MPL_ALLTOALLV_REAL8(PSENDBUF,KSENDCOUNTS,PRECVBUF,KRECVCOUNTS,& &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLTOALLV => MPI_ALLTOALLV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNTS(:), KRECVCOUNTS(:) REAL(KIND=JPRD), INTENT(IN) :: PSENDBUF(:) REAL(KIND=JPRD), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM ,KMP_TYPE INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL,TARGET :: KSENDDISPL(:),KRECVDISPL(:) CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR INTEGER(KIND=JPIM),TARGET :: IRECVDISPL(MPL_NUMPROC),ISENDDISPL(MPL_NUMPROC) INTEGER(KIND=JPIM),POINTER :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) ISENDCOUNT=SIZE(PSENDBUF) IRECVCOUNT=SIZE(PRECVBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1))) - LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 8_JPIB*(ISENDCOUNT - 1) .AND. & & ISENDCOUNT > 0 ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF IF (IRECVCOUNT > 0) THEN IF( (LOC(PRECVBUF(UBOUND(PRECVBUF,1))) - LOC(PRECVBUF(LBOUND(PRECVBUF,1)))) /= 8_JPIB*(IRECVCOUNT - 1) .AND. & & IRECVCOUNT > 0 ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif LLSCALAR=.FALSE. IERROR=0 CALL MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,ISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,IRECVDISPL,KIRECVDISPL_PT,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLTOALLV(PSENDBUF(:),KSENDCOUNTS,KISENDDISPL_PT,INT(MPI_REAL8), & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,INT(MPI_REAL8),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_ALLTOALLV',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IALLTOALLV(PSENDBUF(:),KSENDCOUNTS,KISENDDISPL_PT,INT(MPI_REAL8), & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,INT(MPI_REAL8),ICOMM,KREQUEST,IERROR) IF (.NOT. PRESENT(KSENDDISPL) .OR. .NOT. PRESENT(KRECVDISPL)) THEN ! in this case the preamble has set the linked list for the missing displacements CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) END IF ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_ALLTOALLV',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(IERROR,'ERROR IN MPL_ALLTOALLV',& &LDABORT=LLABORT) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),INT(MPI_REAL8)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_REAL8)) ENDIF END SUBROUTINE MPL_ALLTOALLV_REAL8 SUBROUTINE MPL_ALLTOALLV_REAL4(PSENDBUF,KSENDCOUNTS,PRECVBUF,KRECVCOUNTS,& &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLTOALLV => MPI_ALLTOALLV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNTS(:), KRECVCOUNTS(:) REAL(KIND=JPRM), INTENT(IN) :: PSENDBUF(:) REAL(KIND=JPRM), INTENT(OUT) :: PRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM ,KMP_TYPE INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL,TARGET :: KSENDDISPL(:),KRECVDISPL(:) CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR INTEGER(KIND=JPIM),TARGET :: IRECVDISPL(MPL_NUMPROC),ISENDDISPL(MPL_NUMPROC) INTEGER(KIND=JPIM),POINTER :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) ISENDCOUNT=SIZE(PSENDBUF) IRECVCOUNT=SIZE(PRECVBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(PSENDBUF(UBOUND(PSENDBUF,1))) - LOC(PSENDBUF(LBOUND(PSENDBUF,1)))) /= 4_JPIB*(ISENDCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF IF (IRECVCOUNT > 0) THEN IF( (LOC(PRECVBUF(UBOUND(PRECVBUF,1))) - LOC(PRECVBUF(LBOUND(PRECVBUF,1)))) /= 4_JPIB*(IRECVCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif LLSCALAR=.FALSE. IERROR=0 CALL MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,ISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,IRECVDISPL,KIRECVDISPL_PT,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLTOALLV(PSENDBUF(1),KSENDCOUNTS,KISENDDISPL_PT,INT(MPI_REAL4), & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,INT(MPI_REAL4),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IALLTOALLV(PSENDBUF(1),KSENDCOUNTS,KISENDDISPL_PT,INT(MPI_REAL4), & & PRECVBUF(:),KRECVCOUNTS,KIRECVDISPL_PT,INT(MPI_REAL4),ICOMM,KREQUEST,IERROR) IF (.NOT. PRESENT(KSENDDISPL) .OR. .NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) END IF ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_ALLTOALLV',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(IERROR,'ERROR IN MPL_ALLTOALLV',& &LDABORT=LLABORT) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),INT(MPI_REAL4)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_REAL4)) ENDIF END SUBROUTINE MPL_ALLTOALLV_REAL4 SUBROUTINE MPL_ALLTOALLV_INTEGER(KSENDBUF,KSENDCOUNTS,KRECVBUF,KRECVCOUNTS,& &KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_ALLTOALLV => MPI_ALLTOALLV8 #endif IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNTS(:), KRECVCOUNTS(:) INTEGER(KIND=JPIM), INTENT(IN) :: KSENDBUF(:) INTEGER(KIND=JPIM), INTENT(OUT) :: KRECVBUF(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL,TARGET :: KSENDDISPL(:), KRECVDISPL(:) INTEGER(KIND=JPIM), INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR INTEGER(KIND=JPIM),TARGET :: IRECVDISPL(MPL_NUMPROC),ISENDDISPL(MPL_NUMPROC) INTEGER(KIND=JPIM),POINTER :: KISENDDISPL_PT(:),KIRECVDISPL_PT(:) ISENDCOUNT=SIZE(KSENDBUF) IRECVCOUNT=SIZE(KRECVBUF) #ifndef NAGFOR IF (ISENDCOUNT > 0) THEN IF( (LOC(KSENDBUF(UBOUND(KSENDBUF,1))) - LOC(KSENDBUF(LBOUND(KSENDBUF,1)))) /= 4_JPIB*(ISENDCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: SENDBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF IF (IRECVCOUNT > 0) THEN IF( (LOC(KRECVBUF(UBOUND(KRECVBUF,1))) - LOC(KRECVBUF(LBOUND(KRECVBUF,1)))) /= 4_JPIB*(IRECVCOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_ALLTOALLV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif LLSCALAR=.FALSE. IERROR=0 CALL MPL_ALLTOALLV_PREAMB(KSENDCOUNTS,ISENDDISPL,KISENDDISPL_PT,& & KRECVCOUNTS,IRECVDISPL,KIRECVDISPL_PT,KSENDDISPL,KRECVDISPL,KMP_TYPE,KCOMM,KREQUEST,CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_ALLTOALLV(KSENDBUF(1),KSENDCOUNTS,KISENDDISPL_PT,INT(MPI_INTEGER), & & KRECVBUF(1),KRECVCOUNTS,KIRECVDISPL_PT,INT(MPI_INTEGER),ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN IF(.NOT.PRESENT(KREQUEST)) CALL MPL_MESSAGE(KERROR,'MPL_ALLTOALLV',' KREQUEST MISSING',LDABORT=LLABORT) CALL MPI_IALLTOALLV(KSENDBUF(1),KSENDCOUNTS,KISENDDISPL_PT,INT(MPI_INTEGER), & & KRECVBUF(1),KRECVCOUNTS,KIRECVDISPL_PT,INT(MPI_INTEGER),ICOMM,KREQUEST,IERROR) IF (.NOT. PRESENT(KSENDDISPL) .OR. .NOT. PRESENT(KRECVDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) END IF ELSE IF(PRESENT(KERROR)) THEN IERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_ALLTOALLV',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(IERROR,'ERROR IN MPL_ALLTOALLV',& &LDABORT=LLABORT) ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),INT(MPI_INTEGER)) CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_INTEGER)) ENDIF END SUBROUTINE MPL_ALLTOALLV_INTEGER ! ------------------------------------------------------------------ END MODULE MPL_ALLTOALLV_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_ioinit_mod.F900000664000175000017500000000625615157200431025506 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_IOINIT_MOD ! ! Purpose. initialise parallel IO environment ! -------- ! ! ! Interface. ! ---------- ! call mpl_ioinit(...) ! ! Explicit arguments : ! -------------------- ! ! input arguments: ! kop - Style of parallel IO ! kstrout - Number of output processors ! output arguments: ! kerror - error code ! ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! MPL supports 4 styles of MPIIO ! ! kop = 1 - Blocking, non collective, shared file pointer ! using MPI_FILE_WRITE_SHARED, ! MPI_FILE_READ_SHARED ! kop = 2 - Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED, ! MPI_FILE_READ_ORDERED ! kop = 3 - Non Blocking, non collective, shared file pointer ! using MPI_FILE_IWRITE_SHARED, ! MPI_FILE_IREAD_SHARED ! and MPI_WAIT ! kop = 4 - Non Blocking, collective, ordered, shared file pointer ! using MPI_FILE_WRITE_ORDERED_BEGIN/END, ! MPI_FILE_READ_ORDERED_BEGIN/END ! ! Externals. ! ---------- ! ! Reference. ! ---------- ! none yet ! ! Author. ! ------- ! G.Mozdzynski ! ! Modifications. ! -------------- ! Original : 2000-12-08 (Based on MPE_IOINIT) ! ! ----------------------------------------------------------------- ! USE EC_PARKIND, ONLY : JPIM USE MPL_MPIF, ONLY : MPI_UNDEFINED USE MPL_DATA_MODULE, ONLY : MPL_COMM, MPL_RANK IMPLICIT NONE INTEGER(KIND=JPIM) :: MPL_NUMIO INTEGER(KIND=JPIM) :: MPL_IOP INTEGER(KIND=JPIM) :: MPL_COMM_IO PRIVATE PUBLIC :: MPL_IOINIT, MPL_NUMIO, MPL_IOP, MPL_COMM_IO CONTAINS SUBROUTINE MPL_IOINIT(KOP,KSTROUT,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_COMM_SPLIT => MPI_COMM_SPLIT8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KOP,KSTROUT INTEGER(KIND=JPIM),INTENT(OUT) :: KERROR INTEGER(KIND=JPIM) :: COLOR,KEY ! ! ----------------------------------------------------------------- ! ! 1. Preamble ! -------- IF(KOP < 1 .OR. KOP > 4) THEN KERROR = -1 RETURN ENDIF ! ! ----------------------------------------------------------------- ! ! 2. Check Style of Operation and take appropriate action ! ------------------------------------------------------- MPL_NUMIO = KSTROUT MPL_IOP = KOP IF(MPL_RANK <= KSTROUT) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED ENDIF KEY = 0 CALL MPI_COMM_SPLIT(MPL_COMM,COLOR,KEY,MPL_COMM_IO,KERROR) ! ! ! ----------------------------------------------------------------- RETURN END SUBROUTINE MPL_IOINIT END MODULE MPL_IOINIT_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_scatterv_array_tmpl.i900000664000175000017500000000333015157200431027472 0ustar alastairalastairCALL MPL_SCATTERV_PREAMB1(KCOMM,KROOT,KMP_TYPE,KREQUEST) IRECVCOUNT=SIZE(PRECVBUF) IF(IPL_MYRANK == IROOT) THEN IF( .NOT. LLPRESENT_SENDBUF) CALL MPL_MESSAGE(& & CDMESSAGE='MPL_SCATTERV:SENDBUF MISSING',CDSTRING=CDSTRING,& & LDABORT=LLABORT) ISENDBUFSIZE=SIZE(PSENDBUF) CALL MPL_SCATTERV_PREAMB2(KSENDCOUNTS,ISENDDISPL,KSENDDISPL,ISENDDISPL_PT,& & CDSTRING) IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_SCATTERV(PSENDBUF,KSENDCOUNTS,ISENDDISPL_PT,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_ISCATTERV(PSENDBUF,KSENDCOUNTS,ISENDDISPL_PT,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,KREQUEST,IERROR) IF(.NOT. PRESENT(KSENDDISPL)) THEN CALL YDDISPLS_LIST%APPEND(KREQ=KREQUEST,NO_NEW_NODE=.TRUE.) ENDIF ENDIF IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(SUM(KSENDCOUNTS),IDATA_TYPE) CALL MPL_RECVSTATS(IRECVCOUNT,IDATA_TYPE) ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_SCATTERV(ZDUM_INT,1,1,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,IERROR) ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_ISCATTERV(ZDUM_INT,1,1,IDATA_TYPE, & & PRECVBUF,IRECVCOUNT,IDATA_TYPE,IROOT-1,ICOMM,KREQUEST,IERROR) ENDIF IF(LMPLSTATS) THEN CALL MPL_RECVSTATS(IRECVCOUNT,IDATA_TYPE) ENDIF ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF (IERROR/=0) CALL MPL_MESSAGE(IERROR,'MPL_SCATTERV',& & CDSTRING,LDABORT=LLABORT) ENDIF fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_barrier_mod.F900000664000175000017500000000520715157200431025634 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BARRIER_MOD !**** MPL_BARRIER - Barrier synchronisation ! Purpose. ! -------- ! Blocks the caller until all group members have called it. !** Interface. ! ---------- ! CALL MPL_BARRIER ! Input required arguments : ! ------------------------- ! none ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_BARRIER aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! Threadsafe: 2004-12-15, J.Hague ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPIM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_NUMPROC USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE LOGICAL :: LLABORT=.TRUE. PUBLIC MPL_BARRIER CONTAINS SUBROUTINE MPL_BARRIER(KCOMM,CDSTRING,KERROR) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_BARRIER => MPI_BARRIER8 #endif INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER :: ICOMM,IERROR,ITID IERROR = 0 ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE(CDSTRING=CDSTRING,& & CDMESSAGE='MPL_BARRIER: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF CALL MPI_BARRIER(ICOMM,IERROR) IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_BARRIER',CDSTRING,LDABORT=LLABORT) ENDIF RETURN END SUBROUTINE MPL_BARRIER END MODULE MPL_BARRIER_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/ec_mpi_atexit.c0000664000175000017500000000223115157200431025167 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ec_mpi_atexit.c */ #include #include #include #include #include #include #include "mpl.h" /* A routine to be called at the very end in case MPI wasn't finalized */ /* Registered *only* by MPL_INIT */ /* Disable this feature via : export EC_MPI_ATEXIT=0 */ void ec_mpi_atexit_(void) { char *env = getenv("EC_MPI_ATEXIT"); int do_it = env ? atoi(env) : 1; static int callnum = 0; ++callnum; if (do_it) { if (callnum == 1) { /* register */ atexit(ec_mpi_atexit_); } else if (callnum == 2) { /* action : finish MPI via F90 mpl_end (in mpl_bindc.F90) */ mpl_end(); } } } void ec_mpi_atexit(void) { ec_mpi_atexit_(); } fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_buffer_method_mod.F900000664000175000017500000001037015157200431027014 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_BUFFER_METHOD_MOD !**** MPL_BUFFER_METHOD Establish message passing default method ! Purpose. ! -------- ! Setup the message passing buffering ! by allocating an attached buffer if required. !** Interface. ! ---------- ! CALL MPL_BUFFER_METHOD ! Input required arguments : ! ------------------------- ! KMP_TYPE - buffering type ! possible values are : ! JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED ! defined as parameters in MPL_DATA_MODULE ! Input optional arguments : ! ------------------------- ! KMBX_SIZE - Size (in bytes) of attached buffer ! if KMP_TYPE=JP_BLOCKING_BUFFERED ! KPROCIDS - array of processor ids ! LDINFO - = .TRUE. : Print informative msgs from MPL_INIT (default) ! = .FALSE. : Do not print ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KERROR - return error code. If not supplied, ! MPL_BUFFER_METHOD aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE MPL_DATA_MODULE, ONLY : MPL_ATTACHED_BUFFER, MPL_IDS, MPL_MBX_SIZE, MPL_METHOD, MPL_NUMPROC, MPL_RANK, MPL_UNIT, & & JP_ATTACHED_BUFFER_BYTES, JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED!, & USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE IMPLICIT NONE PRIVATE PUBLIC MPL_BUFFER_METHOD CONTAINS SUBROUTINE MPL_BUFFER_METHOD(KMP_TYPE,KMBX_SIZE,KERROR,KPROCIDS,LDINFO) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_BUFFER_DETACH => MPI_BUFFER_DETACH8, MPI_BUFFER_ATTACH => MPI_BUFFER_ATTACH8 #endif INTEGER(KIND=JPIM),INTENT(IN) :: KMP_TYPE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KMBX_SIZE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROCIDS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KERROR LOGICAL,INTENT(IN),OPTIONAL :: LDINFO INTEGER(KIND=JPIM) :: IMBX_DEFAULT_SIZE = 1000000 INTEGER(KIND=JPIM) :: IBUFFMPI,IERROR,ILEN LOGICAL :: LLABORT=.TRUE., LLINFO IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_BUFFER_METHOD: MPL NOT INITIALISED ',LDABORT=LLABORT) IF (ALLOCATED(MPL_ATTACHED_BUFFER)) THEN CALL MPI_BUFFER_DETACH(MPL_ATTACHED_BUFFER,MPL_MBX_SIZE,IERROR) DEALLOCATE(MPL_ATTACHED_BUFFER) ENDIF IF(PRESENT(LDINFO)) THEN LLINFO = LDINFO ELSE LLINFO = .TRUE. ENDIF IF(KMP_TYPE == JP_BLOCKING_STANDARD) THEN IBUFFMPI=MPL_MBX_SIZE ELSE IF(KMP_TYPE == JP_BLOCKING_BUFFERED) THEN IBUFFMPI=KMBX_SIZE IF(IBUFFMPI == 0) IBUFFMPI=IMBX_DEFAULT_SIZE ! convert to bytes ILEN = (IBUFFMPI-1)/JP_ATTACHED_BUFFER_BYTES+1 ALLOCATE(MPL_ATTACHED_BUFFER(ILEN)) #ifdef OPS_COMPILE IERROR = 0 #else CALL MPI_BUFFER_ATTACH(MPL_ATTACHED_BUFFER,IBUFFMPI,IERROR) #endif IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF( IERROR /= 0 )THEN CALL MPL_MESSAGE(IERROR,'MPL_BUFFER_METHOD ','MPI_BUFFER_ATTACH ERROR',LDABORT=LLABORT) ENDIF ENDIF ELSE ! invalid type IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KMP_TYPE,'MPL_BUFFER_METHOD','INVALID KMP_TYPE=',LDABORT=LLABORT) ENDIF ENDIF MPL_MBX_SIZE=IBUFFMPI MPL_METHOD=KMP_TYPE IF (MPL_RANK == 1) THEN IF (LLINFO) WRITE(MPL_UNIT,'(A,I2,I12)') 'MPL_BUFFER_METHOD: ',MPL_METHOD,MPL_MBX_SIZE ENDIF IF(PRESENT(KPROCIDS)) THEN IF(SIZE(KPROCIDS) < MPL_NUMPROC) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_BUFFER_METHOD: KPROCIDS NOT CORRECT',LDABORT=LLABORT) ELSE MPL_IDS=KPROCIDS ENDIF ENDIF RETURN END SUBROUTINE MPL_BUFFER_METHOD END MODULE MPL_BUFFER_METHOD_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/internal_deprecated/mpl_send_mod.F900000664000175000017500000012510715157200431025141 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_SEND_MOD !**** MPL_SEND Send a message ! Purpose. ! -------- ! Send a message to a named source from a buffer. ! The data may be REAL*4, REAL*8,or INTEGER, one dimensional array ! REAL*4,or REAL*8, two dimensional array ! or INTEGER scalar !** Interface. ! ---------- ! CALL MPL_SEND ! Input required arguments : ! ------------------------- ! PBUF - buffer containing message ! (can be type REAL*4, REAL*8 or INTEGER) ! KTAG - message tag ! KDEST - rank of process to receive the message ! Input optional arguments : ! ------------------------- ! KCOMM - Communicator number if different from MPI_COMM_WORLD ! or from that established as the default ! by an MPL communicator routine ! KMP_TYPE - buffering type (see MPL_BUFFER_METHOD) ! overrides value provided to MPL_BUFFER_METHOD ! CDSTRING - Character string for ABORT messages ! used when KERROR is not provided ! Output required arguments : ! ------------------------- ! none ! Output optional arguments : ! ------------------------- ! KREQUEST - Communication request ! required when buffering type is non-blocking ! KERROR - return error code. If not supplied, ! MPL_SEND aborts when an error is detected. ! Author. ! ------- ! D.Dent, M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2000-09-01 ! P. Marguinaud : 01-Jan-2011 : Do not raise an error when ! the numproc is beyond model limits and KCOMM is passed ! as argument ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY : JPRD, JPIM, JPIB, JPRM USE OML_MOD, ONLY : OML_MY_THREAD USE MPL_MPIF, ONLY : MPI_BYTE, MPI_INTEGER, MPI_INTEGER8, MPI_REAL4, MPI_REAL8 USE MPL_DATA_MODULE, ONLY : MPL_COMM_OML, MPL_ERRUNIT, MPL_METHOD, MPL_NUMPROC, MPL_OUTPUT, MPL_UNIT, & & JP_BLOCKING_STANDARD, JP_BLOCKING_BUFFERED, JP_BLOCKING_SYNCHRONOUS, & & JP_NON_BLOCKING_STANDARD, JP_NON_BLOCKING_BUFFERED USE MPL_MESSAGE_MOD, ONLY : MPL_MESSAGE USE MPL_NPROC_MOD, ONLY : MPL_NPROC USE MPL_STATS_MOD, ONLY : MPL_SENDSTATS USE YOMMPLSTATS, ONLY : LMPLSTATS IMPLICIT NONE PRIVATE !---Moved into subroutines to keep threadsafe---- ! INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR ! LOGICAL :: LLABORT=.TRUE. INTERFACE MPL_SEND MODULE PROCEDURE MPL_SEND_REAL4, MPL_SEND_REAL8,& & MPL_SEND_INT, MPL_SEND_REAL42, MPL_SEND_REAL43, & & MPL_SEND_REAL82,MPL_SEND_REAL83, MPL_SEND_INT_SCALAR, & & MPL_SEND_INT2, MPL_SEND_CHAR_SCALAR, & & MPL_SEND_REAL4_SCALAR, MPL_SEND_REAL8_SCALAR, & & MPL_SEND_INT8, MPL_SEND_CHAR END INTERFACE PUBLIC MPL_SEND CONTAINS SUBROUTINE MPL_SEND_REAL4(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_m,intent(in) :: PBUF(:) REAL(KIND=JPRM) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1))) - LOC(PBUF(LBOUND(PBUF,1)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF(1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF(1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF(1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF(1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF(1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL4 SUBROUTINE MPL_SEND_REAL8(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:) REAL(KIND=JPRD) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1))) - LOC(PBUF(LBOUND(PBUF,1)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF(1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF(1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF(1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF(1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF(1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL8 SUBROUTINE MPL_SEND_INT(KBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIM) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID,IDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(KBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1)))-LOC(KBUF(LBOUND(KBUF,1)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KBUF(1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KBUF(1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KBUF(1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KBUF(1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KBUF(1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT SUBROUTINE MPL_SEND_INT2(KBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIM) :: KBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID,IDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(KBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1),UBOUND(KBUF,2))) - & & LOC(KBUF(LBOUND(KBUF,1),LBOUND(KBUF,2)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(IDUM,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KBUF(1,1),ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT2 SUBROUTINE MPL_SEND_INT8(KBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIB) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID INTEGER(KIND=JPIB) :: IDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(KBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(KBUF(UBOUND(KBUF,1))) - LOC(KBUF(LBOUND(KBUF,1)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER8)) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(IDUM,ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(IDUM,ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(IDUM,ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(IDUM,ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(IDUM,ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KBUF(1),ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KBUF(1),ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KBUF(1),ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KBUF(1),ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KBUF(1),ICOUNT,INT(MPI_INTEGER8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT8 SUBROUTINE MPL_SEND_INT_SCALAR(KINT,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif INTEGER(KIND=JPIM) :: KINT INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = 1 IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_INTEGER)) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(KINT,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(KINT,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(KINT,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(KINT,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(KINT,ICOUNT,INT(MPI_INTEGER),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_INT_SCALAR SUBROUTINE MPL_SEND_REAL42(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_m,intent(in) :: PBUF(:,:) REAL(KIND=JPRM) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRM) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF(1,1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF(1,1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF(1,1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF(1,1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF(1,1),ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL42 SUBROUTINE MPL_SEND_REAL43(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:,:,:) REAL(KIND=JPRM) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM).AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3)))) /= 4_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL43 SUBROUTINE MPL_SEND_REAL82(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:,:) REAL(KIND=JPRD) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID REAL(KIND=JPRD) :: ZDUM(1:0) ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF (ICOUNT == 0) THEN IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(ZDUM,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ELSE IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF(1,1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF(1,1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF(1,1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF(1,1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF(1,1),ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL82 SUBROUTINE MPL_SEND_CHAR_SCALAR(CDCHAR,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif CHARACTER(LEN=*) :: CDCHAR INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = LEN(CDCHAR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_CHAR_SCALAR SUBROUTINE MPL_SEND_CHAR(CDCHAR,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif CHARACTER(LEN=*) :: CDCHAR(:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = LEN(CDCHAR) * SIZE(CDCHAR) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_BYTE)) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(CDCHAR,ICOUNT,INT(MPI_BYTE),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_CHAR SUBROUTINE MPL_SEND_REAL4_SCALAR(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif REAL(KIND=JPRM) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = 1 IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL4)) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,INT(MPI_REAL4),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL4_SCALAR SUBROUTINE MPL_SEND_REAL8_SCALAR(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif REAL(KIND=JPRD) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF((KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM)) .AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = 1 IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL8_SCALAR SUBROUTINE MPL_SEND_REAL83(PBUF,KDEST,KTAG,KCOMM,KMP_TYPE,KERROR,KREQUEST,CDSTRING) #ifdef USE_8_BYTE_WORDS USE MPI4TO8, ONLY : & MPI_SEND => MPI_SEND8, MPI_BSEND => MPI_BSEND8, MPI_ISEND => MPI_ISEND8 #endif ! real_b,intent(in) :: PBUF(:,:,:) REAL(KIND=JPRD) :: PBUF(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDEST,KTAG INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KCOMM,KMP_TYPE INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KREQUEST,KERROR CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: CDSTRING INTEGER(KIND=JPIM) :: ICOUNT,IMP_TYPE,ICOMM,IERROR LOGICAL :: LLABORT=.TRUE. INTEGER(KIND=JPIM) :: ITID ITID = OML_MY_THREAD() IF(MPL_NUMPROC < 1) CALL MPL_MESSAGE( & & CDMESSAGE='MPL_SEND: MPL NOT INITIALISED ',LDABORT=LLABORT) IF(PRESENT(KMP_TYPE)) THEN IMP_TYPE=KMP_TYPE ELSE IMP_TYPE=MPL_METHOD ENDIF IF(PRESENT(KCOMM)) THEN ICOMM=KCOMM ELSE ICOMM=MPL_COMM_OML(ITID) ENDIF IF(KDEST < 1 .OR. KDEST >MPL_NPROC(ICOMM).AND. (.NOT. PRESENT (KCOMM))) THEN WRITE(MPL_ERRUNIT,*)'MPL_SEND: ERROR KDEST=',KDEST CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND:ILLEGAL KDEST ',LDABORT=LLABORT) ENDIF ICOUNT = SIZE(PBUF) IF(LMPLSTATS) THEN CALL MPL_SENDSTATS(ICOUNT,INT(MPI_REAL8)) ENDIF #ifndef NAGFOR IF (ICOUNT > 0) THEN IF( (LOC(PBUF(UBOUND(PBUF,1),UBOUND(PBUF,2),UBOUND(PBUF,3))) - & & LOC(PBUF(LBOUND(PBUF,1),LBOUND(PBUF,2),LBOUND(PBUF,3)))) /= 8_JPIB*(ICOUNT - 1) ) THEN CALL MPL_MESSAGE(CDMESSAGE='MPL_SEND: BUFFER NOT CONTIGUOUS ',LDABORT=LLABORT) ENDIF ENDIF #endif IF(IMP_TYPE == JP_BLOCKING_STANDARD) THEN CALL MPI_SEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_BUFFERED) THEN CALL MPI_BSEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_STANDARD) THEN CALL MPI_ISEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN CALL MPI_IBSEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM, & & KREQUEST,IERROR) ELSE IF(IMP_TYPE == JP_BLOCKING_SYNCHRONOUS) THEN CALL MPI_SSEND(PBUF,ICOUNT,INT(MPI_REAL8),KDEST-1,KTAG,ICOMM,IERROR) ELSE IF(PRESENT(KERROR)) THEN KERROR=1 ELSE CALL MPL_MESSAGE(KERROR,'MPL_SEND',' INVALID METHOD',LDABORT=LLABORT) ENDIF ENDIF IF(MPL_OUTPUT > 1 )THEN WRITE(MPL_UNIT,'(A,5I8)') ' MPL_SEND ',ICOUNT,IMP_TYPE,KDEST,KTAG,ICOMM ENDIF IF(PRESENT(KERROR)) THEN KERROR=IERROR ELSE IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_SEND',CDSTRING,LDABORT=LLABORT) ENDIF END SUBROUTINE MPL_SEND_REAL83 END MODULE MPL_SEND_MOD fiat-ecmwf-2.0.0/src/fiat/mpl/mpl_module.F900000664000175000017500000000315015157200431020633 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE MPL_MODULE ! ! Message Passing Library (MPL) ! ! Interface between parallel applications and the ! Message Passing Interface (MPI standard) provided by the computer vendors ! This version requires only MPI release 1. ! ! designed and developed by ! Mats Hamrud and David Dent, ECMWF, September 2000 ! ! all routines which wish to call MPL routines must contain: ! USE MPL_MODULE USE MPL_MPI USE MPL_DATA_MODULE USE MPL_INIT_MOD USE MPL_BUFFER_METHOD_MOD USE MPL_SEND_MOD USE MPL_RECV_MOD USE MPL_WAIT_MOD USE MPL_BARRIER_MOD USE MPL_BROADCAST_MOD USE MPL_PROBE_MOD USE MPL_END_MOD USE MPL_MESSAGE_MOD USE MPL_ABORT_MOD USE MPL_COMM_COMPARE_MOD USE MPL_COMM_CREATE_MOD USE MPL_COMM_FREE_MOD USE MPL_COMM_SPLIT_MOD USE MPL_SETDFLT_COMM_MOD USE MPL_ALLGATHER_MOD USE MPL_MYRANK_MOD USE MPL_NPROC_MOD USE MPL_IOINIT_MOD USE MPL_OPEN_MOD USE MPL_CLOSE_MOD USE MPL_READ_MOD USE MPL_WRITE_MOD USE MPL_ALLREDUCE_MOD USE MPL_GATHERV_MOD USE MPL_MYGATHERV_MOD USE MPL_ALLGATHERV_MOD USE MPL_ALLTOALLV_MOD USE MPL_SCATTERV_MOD USE MPL_GROUPS USE MPL_ARG_MOD USE MPL_LOCOMM_CREATE_MOD USE MPL_TOUR_TABLE_MOD USE MPL_TESTSOME_MOD USE MPL_WAITANY_MOD USE MPL_BYTES_MOD END MODULE MPL_MODULE fiat-ecmwf-2.0.0/src/fiat/ecsort/0000775000175000017500000000000015157200431016726 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/ecsort/internal/0000775000175000017500000000000015157200431020542 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/ecsort/internal/addrdiff.c0000664000175000017500000000104715157200431022453 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* Address difference in bytes */ void addrdiff_(const char *p1, const char *p2, int *diff) { *diff = (p2 - p1); } fiat-ecmwf-2.0.0/src/fiat/ecsort/internal/rsort64.c0000664000175000017500000001427015157200431022235 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include "raise.h" /* rsort64_() : 64-bit Fortran-callable RADIX-sort */ /* by Sami Saarinen, ECMWF, 22/02/2005 : Initial version derived from rsort32.c - " - 23/02/2005 : Fixes and some optimizations - " - 07/07/2005 : Mods in index_adj & bitsum - " - 07/02/2007 : Intercepting alloc (IBM & NEC SX) + NEC SX vectorization Thanks to Mike Fisher, ECMWF and Cray SCILIB ORDERS()-function developers */ /* Methods: 2 : 64-bit doubles (IEEE) : signbit + 11-bit exp + 52-bits mantissa 4 : Signed 64-bit ints 5 : Unsigned 64-bit ints */ typedef unsigned int Uint32; typedef unsigned long long int Uint64; typedef unsigned char Uchar; /* scalar prozezzorz */ static int SpeedUp = 1; #define SORT_R64 2 #define SORT_I64 4 #define SORT_U64 5 typedef long long int ll_t; #define ALLOC(x,size) \ { ll_t bytes = (ll_t)sizeof(*x) * (size); \ bytes = (bytes < 1) ? 1 : bytes; \ x = malloc(bytes); \ if (!x) { fprintf(stderr, \ "malloc() of %s (%lld bytes) failed in file=%s, line=%d\n", \ #x, bytes, __FILE__, __LINE__); RAISE(SIGABRT); } } #define FREE(x) if (x) { free(x); x = NULL; } #define BITSUM(x) bitsum[x] += ((item >> x) & 1ull) #define SIGNBIT64 0x8000000000000000ull #define MASKALL64 0xFFFFFFFFFFFFFFFFull #define ZEROALL64 0x0000000000000000ull #define CVMGM(a,b,c) ( ((c) & SIGNBIT64) ? (a) : (b) ) #define N64BITS 64 void rsort64_(const int *Mode, /* if < 10, then index[] needs to be initialized ; method = modulo 10 */ const int *N, /* no. of 64-bit elements */ const int *Inc, /* stride in terms of 64-bit elements */ const int *Start_addr, /* Fortran start address i.e. normally == 1 */ Uint64 Data[], /* 64-bit elements to be sorted */ int index[], /* sorting index */ const int *Index_adj, /* 0=index[] is a C-index, 1=index[] is a Fortran-index (the usual case) */ int *retc) { int mode = *Mode; int method = mode%10; int n = *N; int rc = n; int inc = *Inc; int index_adj = *Index_adj; int addr = (*Start_addr) - 1; /* Fortran to C */ int i, j, jj; Uchar xorit = 0; Uchar copytmp = 0; Uchar alloc_data = 0; Uint64 *data = NULL; int *tmp = NULL; Uint32 bitsum[N64BITS]; if (method != SORT_R64 && method != SORT_I64 && method != SORT_U64 ) { rc = -1; goto finish; } if (n <= 0) { if (n < 0) rc = -2; goto finish; } if (inc < 1) { rc = -3; goto finish; } if (mode < 10) { /* index[] needs to be initialized */ for (i=0; i 1) || (method == SORT_R64)); if (alloc_data) ALLOC(data, n); if (method == SORT_R64) { for (i=0; i 1) { for (i=0; i 0 && sum < n) { /* if 0 or n, then the whole column of bits#j 0's or 1's */ Uint64 mask = (1ull << j); int *i1, *i2; if (jj%2 == 0) { i1 = index; i2 = tmp; copytmp = 1; } else { i1 = tmp; i2 = index; copytmp = 0; } if (SpeedUp == 0) { int k = 0; for (i=0; i 0 && sum < n) */ } if (copytmp) for (i=0; i 1 .and. nomp >= inumt .and. n >= nomp) LLomp_okay = (LLomp_okay .and. .not. OML_IN_PARALLEL()) ! Prevents nested OpenMP if (LLomp_okay) then !-- Max 2-way OpenMP parallelism for now ... ichunk = n/2 !$OMP PARALLEL PRIVATE(iret) !$OMP SECTIONS !$OMP SECTION CALL ecqsortfast(KEYSORT_NUMBER, ichunk, a(1), irev, iret) !$OMP SECTION CALL ecqsortfast(KEYSORT_NUMBER, n-ichunk, a(ichunk+1), irev, iret) !$OMP END SECTIONS !$OMP END PARALLEL CALL ecmerge2(KEYSORT_NUMBER, 1, ichunk, n-ichunk, a(1), & & idummy, 0, 1, irev, idummy, rc) else CALL ecqsortfast(KEYSORT_NUMBER, n, a(1), irev, rc) endif GOTO 99 else if (imethod == countingsort_method) then if (.not.present(index)) then CALL ec_countingsort(KEYSORT_NUMBER, n, 1, 1, a(1), idummy, 0, 1, irev, rc) else LLinit = .FALSE. if (present(init)) LLinit = init if (LLinit) then CALL init_index(index, index_adj=-1) index_adj = 0 else index_adj = 1 endif CALL ec_countingsort(KEYSORT_NUMBER, n, 1, 1, a(1), index(1), size(index), index_adj, irev, rc) if (index_adj == 0) CALL adjust_index(index, +1) endif GOTO 99 else LLfast = .false. endif endif !-- LLfast == .FALSE. : allocate(aa(n,1)) if (LLdescending) then aa(1:n,1) = -a(1:n) else aa(1:n,1) = a(1:n) endif CALL keysort(rc, aa, n, method=method, index=index, init=init) if (LLdescending) then a(1:n) = -aa(1:n,1) else a(1:n) = aa(1:n,1) endif deallocate(aa) 99 continue IF (LHOOK) CALL DR_HOOK(KEYSORT_1D_DRHOOKSTR,1,ZHOOK_HANDLE,n) END SUBROUTINE SUBROUTINE KEYSORT_2D(& &rc, a, n,& &key, multikey, method,& &index, init, transposed) INTEGER(KIND=JPIM), intent(out) :: rc DATA_TYPE , intent(inout) :: a(:,:) INTEGER(KIND=JPIM), intent(in) :: n INTEGER(KIND=JPIM), intent(in), OPTIONAL :: key, method INTEGER(KIND=JPIM), intent(in), OPTIONAL :: multikey(:) logical, intent(in), OPTIONAL :: transposed INTEGER(KIND=JPIM), intent(inout), TARGET, OPTIONAL :: index(:) logical, intent(in), OPTIONAL :: init ! === END OF INTERFACE BLOCK === INTEGER(KIND=JPIM), POINTER :: iindex(:) INTEGER(KIND=JPIM) :: ikey, istride, imethod, inumkeys, imethod_1st, imethod_rest INTEGER(KIND=JPIM) :: lda, iptr, i, j, sda, idiff, irev, inumt, jkey, jj, ilastkey INTEGER(KIND=JPIM) :: j1, j2, jmid, inum, imax, iadd, imod, iret, inc, iamax, ibmax DATA_TYPE , allocatable :: data(:) INTEGER(KIND=JPIM), allocatable :: ikeys(:), ista(:), ichunk(:), irank(:) logical LLinit, LLdescending, LLtrans, LLomp_okay, LLadjusted, LLdebug, LLomp_prefix character(len=1) clenv REAL(KIND=JPHOOK) :: ZHOOK_HANDLE, ZHOOK_SUBHANDLE REAL(KIND=JPHOOK) :: ZHOOK_SUBHANDLE0 REAL(KIND=JPHOOK) :: ZHOOK_SUBHANDLE1 REAL(KIND=JPHOOK) :: ZHOOK_SUBHANDLE2 REAL(KIND=JPHOOK) :: ZHOOK_SUBHANDLE3 INTEGER(KIND=JPIM) :: ITID IF (LHOOK) CALL DR_HOOK(KEYSORT_2D_DRHOOKSTR,0,ZHOOK_HANDLE) rc = 0 lda = size(a, dim=1) sda = size(a, dim=2) if (n <= 0 .or. lda <= 0 .or. sda <= 0) goto 99 inumt = OML_MAX_THREADS() ITID = OML_MY_THREAD() imethod = current_method(ITID) if (present(method)) then imethod = min(max(min_method,method),max_method) endif imethod_1st = imethod imethod_rest = imethod ikey = 1 if (present(key)) ikey = key if (present(multikey)) then allocate(ikeys(size(multikey))) ikeys(:) = multikey(:) else allocate(ikeys(1)) ikeys(1) = ikey endif inumkeys = size(ikeys) !-- Only the RADIX-sort & now also QUICK-sort & CountingSort give the result we want with multiple keys if (inumkeys > 1 .and. & imethod /= radixsort_method .and. & imethod /= quicksort_method .and. & imethod /= countingsort_method) then imethod = default_method imethod_1st = imethod imethod_rest = imethod !-- Since "default_method" may now be [overridden as] HEAP-sort, make sure its then "radixsort_method" ! Note: The first sweep may still be e.g. HEAP-sort if (imethod /= radixsort_method .and. & imethod /= quicksort_method .and. & imethod /= countingsort_method) then imethod = radixsort_method imethod_rest = imethod endif endif LLinit = .FALSE. if (present(init)) LLinit = init if (present(index)) then iindex => index(1:n) else allocate(iindex(n)) LLinit = .TRUE. endif if (LLinit) CALL init_index(iindex) istride = 1 LLtrans = .FALSE. if (present(transposed)) LLtrans = transposed if (LLtrans) then istride = lda else if (sda >= 2 .and. lda >= 1) then !-- Check for presence of sub-array and adjust lda automatically call addrdiff(a(1,1),a(1,2),idiff) ! lda below: The true leading dimension; overrides sub-arrays one lda = idiff/SIZEOF_ME endif ilastkey = 0 LLadjusted = .FALSE. LLomp_prefix = .FALSE. !$ LLomp_prefix = (istride == 1 .and. nomp >= inumt .and. n >= nomp) if (LLomp_prefix) then call get_environment_variable('EC_SORTING_DEBUG',clenv) LLdebug = (clenv == '1' .and. n < 10000) if (LLdebug) write(0,*)'>> EC_SORTING_DEBUG=1' else LLdebug = .FALSE. endif 1000 format(1x,a,2i12,:,/,(10i5)) 1001 format(1x,'[#',i2,']:',a,(10i5)) 1002 format(1x,'[#',i2,']:',a,:,/,(10i5)) 1003 format(1x,'[#',i2,']:',a,2i12,:,/,(10i5)) 1004 format(1x,a,:,(10i5)) 1005 format(1x,a,i2,1x,a) imethod = imethod_1st KEYLOOP: do jkey=inumkeys,1,-1 !-- Sort by the least significant key first ikey = abs(ikeys(jkey)) if (ikey == 0) cycle KEYLOOP if (istride == 1) then iptr = lda * (ikey - 1) + 1 else iptr = ikey endif if (LLdebug) then write(0,1000) 'iindex(1:n)=',n,sum(iindex(1:n)),iindex(1:n) if (LLadjusted) then CALL DBGPRINT(-jkey,'',a,iindex,n,ikey,1,n,1) else CALL DBGPRINT(-jkey,'',a,iindex,n,ikey,1,n,0) endif ilastkey = ikey endif LLdescending = (ikeys(jkey) < 0) irev = 0 if (LLdescending) irev = 1 !-- Since "irev" is passed into the ecqsort, no explicit reversing is needed --> savings if (imethod == quicksort_method .or. & imethod == countingsort_method) LLdescending = .FALSE. if (LLdescending) then if (istride == 1) then a(1:n,ikey) = -a(1:n,ikey) else a(ikey,1:n) = -a(ikey,1:n) endif irev = 0 ! prevents use of "reverse" algorithm in ecmerge2 for radix-sort endif LLomp_okay = LLomp_prefix .and. (inumt > 1) .and. (& & imethod == radixsort_method .or. & & imethod == quicksort_method .or. & & imethod == countingsort_method) LLomp_okay = LLomp_okay .and. (.not. OML_IN_PARALLEL()) ! Prevents nested OpenMP if (.not.LLomp_okay) then select case (imethod) case (radixsort_method) IF (LHOOK) CALL DR_HOOK(RSORT_DRHOOKSTR,0,ZHOOK_SUBHANDLE0) #if USE_RSORT64 == 1 CALL rsort64(KEYSORT_NUMBER, n, istride, iptr, a(1,1), iindex(1), 1, rc) #else CALL rsort32_func(KEYSORT_NUMBER, n, istride, iptr, a(1,1), iindex(1), 1, rc) #endif IF (LHOOK) CALL DR_HOOK(RSORT_DRHOOKSTR,1,ZHOOK_SUBHANDLE0, n) case (heapsort_method) if (istride == 1) then CALL HEAPSORT(KEYSORT_NUMBER, n, a(1:n, ikey), rc, irev, istride, iindex) else CALL HEAPSORT(KEYSORT_NUMBER, n, a(ikey, 1:n), rc, irev, istride, iindex) endif case (quicksort_method) IF (LHOOK) CALL DR_HOOK(ECQSORT_DRHOOKSTR,0,ZHOOK_SUBHANDLE0) CALL ecqsort(KEYSORT_NUMBER, n, istride, iptr, a(1,1), iindex(1), 1, irev, rc) IF (LHOOK) CALL DR_HOOK(ECQSORT_DRHOOKSTR,1,ZHOOK_SUBHANDLE0,n) case (countingsort_method) IF (LHOOK) CALL DR_HOOK(COUNT_DRHOOKSTR,0,ZHOOK_SUBHANDLE0) CALL ec_countingsort(KEYSORT_NUMBER, n, istride, iptr, a(1,1), iindex(1), n, 1, irev, rc) IF (LHOOK) CALL DR_HOOK(COUNT_DRHOOKSTR,1,ZHOOK_SUBHANDLE0,n) case (gnomesort_method) IF (LHOOK) CALL DR_HOOK(GNOME_DRHOOKSTR,0,ZHOOK_SUBHANDLE0) CALL ecgnomesort(KEYSORT_NUMBER, n, istride, iptr, a(1,1), iindex(1), n, 1, rc) IF (LHOOK) CALL DR_HOOK(GNOME_DRHOOKSTR,1,ZHOOK_SUBHANDLE0,n) end select else ! i.e. LLomp_okay ; radix, quick & counting -sorts only if (.not.allocated(ista)) then allocate(ista(inumt+1),ichunk(inumt)) inc = n/inumt iadd = 1 imod = mod(n,inumt) if (imod == 0) iadd = 0 ista(1) = 1 do j=2,inumt ista(j) = ista(j-1) + inc + iadd if (iadd > 0 .and. j > imod) iadd = 0 enddo ista(inumt+1) = n + 1 do j=1,inumt ichunk(j) = ista(j+1) - ista(j) enddo if (LLdebug) then write(0,1005) '>> imethod,name=',imethod,method_name(imethod) write(0,1004) '>> inumt,n,nomp=',inumt,n,nomp write(0,1004) '>> ista(1:inumt+1)=',ista(1:inumt+1) write(0,1004) '>> ichunk(1:inumt)=',ichunk(1:inumt) endif allocate(irank(n)) endif if (LLdebug) write(0,1004) '>>KEYLOOP: jkey,ikey,irev,iptr=',jkey,ikey,irev,iptr if (.not.LLadjusted) then ! only once if (LLdebug) write(0,1000) '<1>iindex(1:n)=',n,sum(iindex(1:n)),iindex(1:n) call adjust_index(iindex, -1) ! Fortran -> C if (LLdebug) write(0,1000) '<2>iindex(1:n)=',n,sum(iindex(1:n))+n,iindex(1:n) LLadjusted = .TRUE. endif if (LLdebug) write(0,*)'>> Sorting inumt-chunks in parallel' !$OMP PARALLEL PRIVATE(j,j1,j2,inum,iret,inc,ITID,ZHOOK_SUBHANDLE1,ZHOOK_SUBHANDLE2) IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:KEYSORT_2D>OMPSORT',0,ZHOOK_SUBHANDLE1) ITID = OML_MY_THREAD() !$OMP DO SCHEDULE(DYNAMIC,1) do j=1,inumt j1 = ista(j) inum = ichunk(j) j2 = j1 + inum - 1 inc = j1 if (LLdebug) write(0,1001) ITID,'j,j1,j2,inum,inc=',j,j1,j2,inum,inc if (LLdebug) write(0,1002) ITID,'iindex(j1:j2) > ',iindex(j1:j2) select case (imethod) case (radixsort_method) IF (LHOOK) CALL DR_HOOK(RSORT_DRHOOKSTR,0,ZHOOK_SUBHANDLE2) #if USE_RSORT64 == 1 CALL rsort64(KEYSORT_NUMBER, inum, istride, iptr, a(1,1), iindex(j1), 0, iret) #else CALL rsort32_func(KEYSORT_NUMBER, inum, istride, iptr, a(1,1), iindex(j1), 0, iret) #endif IF (LHOOK) CALL DR_HOOK(RSORT_DRHOOKSTR,1,ZHOOK_SUBHANDLE2, inum) case (quicksort_method) IF (LHOOK) CALL DR_HOOK(ECQSORT_DRHOOKSTR,0,ZHOOK_SUBHANDLE2) CALL ecqsort(KEYSORT_NUMBER, inum, istride, iptr, a(1,1), iindex(j1), 0, irev, iret) IF (LHOOK) CALL DR_HOOK(ECQSORT_DRHOOKSTR,1,ZHOOK_SUBHANDLE2,inum) case (countingsort_method) IF (LHOOK) CALL DR_HOOK(COUNT_DRHOOKSTR,0,ZHOOK_SUBHANDLE2) CALL ec_countingsort(KEYSORT_NUMBER, inum, istride, iptr, a(1,1), iindex(j1), inum, 0, irev, iret) IF (LHOOK) CALL DR_HOOK(COUNT_DRHOOKSTR,1,ZHOOK_SUBHANDLE2,inum) end select if (LLdebug) write(0,1002) ITID,'iindex(j1:j2) < ',iindex(j1:j2) enddo !$OMP END DO IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:KEYSORT_2D>OMPSORT',1,ZHOOK_SUBHANDLE1) !$OMP END PARALLEL if (LLdebug) write(0,1000) 'iindex(1:n)=',n,sum(iindex(1:n))+n,iindex(1:n) if (LLdebug) CALL DBGPRINT(0,'',a,iindex,n,ikey,1,n,1) CALL get_rank(iindex, irank, index_adj=+1) if (LLdebug) write(0,*) '>> Merge neighbouring chunks in parallel as much as possible' inc = 2 imax = (inumt+inc-1)/inc do jj=1,imax if (LLdebug) write(0,1001) jj,' jj,inc,imax,inumt=',jj,inc,imax,inumt !$OMP PARALLEL PRIVATE(j,j1,j2,inum,iamax,ibmax,jmid,iret,ZHOOK_SUBHANDLE3,ITID) IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:KEYSORT_2D>OMPMERGE',0,ZHOOK_SUBHANDLE3) ITID = OML_MY_THREAD() !$OMP DO SCHEDULE(DYNAMIC,1) do j=1,inumt,inc j1 = j j2 = j + inc - 1 jmid = (j1 + j2)/2 + 1 j2 = min(j2,inumt) jmid = min(jmid,inumt) if (LLdebug) write(0,1001) ITID,'j,j1,j2,jmid=',j,j1,j2,jmid iamax = ista(jmid) - ista(j1) inum = sum(ichunk(j1:j2)) ibmax = inum - iamax if (LLdebug) write(0,1001) ITID,'j,iamax,ibmax,inum=',j,iamax,ibmax,inum if (iamax == 0 .or. ibmax == 0 .or. inum == 0) cycle j1 = ista(j1) j2 = ista(j2+1) - 1 if (LLdebug) write(0,1001) ITID,'j,j1,j2,inum=',j,j1,j2,inum if (LLdebug) write(0,1002) ITID,'iindex(j1:j2) > ',iindex(j1:j2) call ecmerge2(KEYSORT_NUMBER, iptr, iamax, ibmax, a(1,1), & & iindex(j1), inum, 0, irev, irank(1), iret) if (LLdebug) write(0,1002) ITID,'iindex(j1:j2) < ',iindex(j1:j2) enddo ! do j=1,inumt,inc !$OMP END DO IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:KEYSORT_2D>OMPMERGE',1,ZHOOK_SUBHANDLE3) !$OMP END PARALLEL if (LLdebug) write(0,1003) jj,'iindex(1:n)=',n,sum(iindex(1:n))+n,iindex(1:n) if (LLdebug) CALL DBGPRINT(jj,'',a,iindex,n,ikey,1,n,1) inc = inc * 2 enddo ! do jj=1,imax rc = n endif ! if (LLomp_okay) if (LLdescending) then if (istride == 1) then a(1:n,ikey) = -a(1:n,ikey) else a(ikey,1:n) = -a(ikey,1:n) endif endif if (LLadjusted .and. imethod /= imethod_rest) then ! Restore back immediately if (LLdebug) write(0,1000) '<3a>iindex(1:n)=',n,sum(iindex(1:n))+n,iindex(1:n) call adjust_index(iindex, +1) ! C -> Fortran if (LLdebug) write(0,1000) '<4a>iindex(1:n)=',n,sum(iindex(1:n)),iindex(1:n) LLadjusted = .FALSE. endif imethod = imethod_rest enddo KEYLOOP deallocate(ikeys) if (allocated(ista)) deallocate(ista) if (allocated(ichunk)) deallocate(ichunk) if (allocated(irank)) deallocate(irank) if (LLadjusted) then ! Restore back if (LLdebug) write(0,1000) '<3b>iindex(1:n)=',n,sum(iindex(1:n))+n,iindex(1:n) call adjust_index(iindex, +1) ! C -> Fortran if (LLdebug) write(0,1000) '<4b>iindex(1:n)=',n,sum(iindex(1:n)),iindex(1:n) LLadjusted = .FALSE. endif if (LLdebug) write(0,1000) 'iindex(1:n)=',n,sum(iindex(1:n)),iindex(1:n) if (LLdebug) CALL DBGPRINT(0,'',a,iindex,n,ilastkey,1,n,0) if (.not.present(index)) then LLomp_okay = (nomp >= inumt .and. n >= nomp) if (istride == 1) then LLomp_okay = (LLomp_okay .and. sda >= inumt .and. .not. OML_IN_PARALLEL()) ! Prevents nested OpenMP !$OMP PARALLEL PRIVATE(j,data) IF (LLomp_okay) allocate(data(n)) !$OMP DO SCHEDULE(DYNAMIC,1) do j=1,sda data(1:n) = a(iindex(1:n),j) a(1:n,j) = data(1:n) enddo !$OMP END DO deallocate(data) !$OMP END PARALLEL else LLomp_okay = (LLomp_okay .and. lda >= inumt .and. .not. OML_IN_PARALLEL()) ! Prevents nested OpenMP !$OMP PARALLEL PRIVATE(i,data) IF (LLomp_okay) allocate(data(n)) !$OMP DO SCHEDULE(DYNAMIC,1) do i=1,lda data(1:n) = a(i,iindex(1:n)) a(i,1:n) = data(1:n) enddo !$OMP END DO deallocate(data) !$OMP END PARALLEL endif deallocate(iindex) endif 99 continue IF (LHOOK) CALL DR_HOOK(KEYSORT_2D_DRHOOKSTR,1,ZHOOK_HANDLE,n*inumkeys) END SUBROUTINE !----------------------------- !-- Private subroutines -- !----------------------------- SUBROUTINE DBGPRINT(jj, cdstr, a, index, n, key, k1, k2, kadd) character(len=*), intent(in) :: cdstr INTEGER(KIND=JPIM), intent(in) :: jj, n, key, k1, k2, kadd INTEGER(KIND=JPIM), intent(in) :: index(:) DATA_TYPE, intent(in) :: a(:,:) INTEGER(KIND=JPIM) :: i,j 1000 FORMAT(i3,a,5i5) 1011 FORMAT((5i12)) ! integer*4 1012 FORMAT(1p,(5g20.12)) ! real*8 1013 FORMAT(1p,(5g20.12)) ! real*4 1014 FORMAT((5i12)) ! integer*8 WRITE(0,1000) jj,cdstr//': n,key,k1,k2,kadd,a(index(k1:k2)+kadd,:)=',& & n,key,k1,k2,kadd do j=k1,k2 i = index(j)+kadd WRITE(0,'(2i6)',advance='no') j,i-kadd WRITE(0,DBGFMTNUM) a(i,:) enddo END SUBROUTINE SUBROUTINE HEAPSORT(id, n, a, rc, irev, istride, index) INTEGER(KIND=JPIM), intent(in) :: id, n, irev, istride DATA_TYPE, intent(in) :: a(:) INTEGER(KIND=JPIM), intent(out) :: rc INTEGER(KIND=JPIM), intent(inout) :: index(:) INTEGER(KIND=JPIM) :: i,j,right,left,idx DATA_TYPE :: tmp REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK(HEAPSORT_DRHOOKSTR,0,ZHOOK_HANDLE) rc = 0 if (n <= 0 .or. size(a) <= 0) goto 99 left = n/2+1 right = n LOOP: do if (left > 1) then left = left - 1 idx = index(left) else idx = index(right) index(right) = index(1) right = right - 1 if (right == 1) then index(1) = idx exit LOOP endif endif tmp = a(idx) i = left j = 2*left do while (j <= right) if (j < right) then if (a(index(j)) < a(index(j+1))) j = j + 1 endif if (tmp < a(index(j))) then index(i) = index(j) i = j j = 2*j else j = right + 1 endif enddo index(i) = idx enddo LOOP rc = n 99 continue IF (LHOOK) CALL DR_HOOK(HEAPSORT_DRHOOKSTR,1,ZHOOK_HANDLE) END SUBROUTINE #ifndef NO_UNDEF #undef DATA_TYPE #undef SIZEOF_ME #undef KEYSORT_1D #undef KEYSORT_1D_DRHOOKSTR #undef KEYSORT_2D #undef KEYSORT_2D_DRHOOKSTR #undef KEYSORT_NUMBER #undef RSORT_DRHOOKSTR #undef USE_RSORT64 #undef QSORTFAST_DRHOOKSTR #undef HEAPSORT #undef HEAPSORT_DRHOOKSTR #undef DBGPRINT #undef DBGFMTNUM #undef ECQSORT_DRHOOKSTR #undef COUNT_DRHOOKSTR #undef GNOME_DRHOOKSTR #endif fiat-ecmwf-2.0.0/src/fiat/ecsort/internal/ecqsort.c0000664000175000017500000002715615157200431022401 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include "raise.h" /* ecqsort_() : Fortran-callable quick-sort */ /* by Sami Saarinen, ECMWF, 7/07/2005 : Interface derived from rsort32.c & rsort64.c - " - 4/09/2006 : Dr.Hook call for kwiksort_u64_index - " - 7/02/2007 : Intercepting alloc (IBM & NEC SX) + NEC SX vectorization - " - 3/07/2007 : Rewritten to use qsort() standard library routine - " - 15/10/2007 : Fast qsort() added for simple 1-dim cases (see ../include/ecsort_shared.h) - " - 16/10/2007 : Reverse-flag added to avoid explicit negation of the array (cheaper) - " - 03/12/2007 : Dr.Hook calls removed; disturbs when in OMP-region on IBM ; a compiler bug ? */ /* Methods: 0 : Unsigned 32-bit ints 1 : Signed 32-bit ints 2 : 64-bit doubles (IEEE) : signbit + 11-bit exp + 52-bits mantissa 3 : 32-bit floats (IEEE) : signbit + 8-bit exp + 23-bits mantissa 4 : Signed 64-bit ints 5 : Unsigned 64-bit ints */ typedef unsigned long long int Uint64; typedef long long int Sint64; typedef unsigned int Uint32; typedef int Sint32; typedef short int Sint16; typedef signed char Sint8; typedef long long int ll_t; #define ALLOC(x,size) \ { ll_t bytes = (ll_t)sizeof(*x) * (size); \ bytes = (bytes < 1) ? 1 : bytes; \ x = malloc(bytes); \ if (!x) { fprintf(stderr, \ "malloc() of %s (%lld bytes) failed in file=%s, line=%d\n", \ #x, bytes, __FILE__, __LINE__); RAISE(SIGABRT); } } #define FREE(x) if (x) { free(x); x = NULL; } #if defined(NO_TRUNC) /* For systems without trunc() -function [an extension of ANSI-C, but usually available] */ #define trunc(x) ((x) - fmod((x),1)) #else extern double trunc(double d); #endif #define MakeKwikSort(T) \ typedef struct { \ const T *valueptr; \ int j; \ int idx; \ } T##Str_t; \ \ static int \ T##cmp(const T##Str_t *a, const T##Str_t *b) { \ if ( *a->valueptr > *b->valueptr ) return 1; \ else if ( *a->valueptr < *b->valueptr ) return -1; \ else { /* *a->valueptr == *b->valueptr */ \ /* the next line is essential for the stable qsort() */ \ return (a->j > b->j) ? 1 : -1; \ } \ } \ static int \ T##cmp_rev(const T##Str_t *a, const T##Str_t *b) { \ if ( *a->valueptr < *b->valueptr ) return 1; \ else if ( *a->valueptr > *b->valueptr ) return -1; \ else { /* a->valueptr == b->valueptr */ \ /* the next line is essential for the stable qsort() */ \ return (a->j > b->j) ? 1 : -1; \ } \ } \ \ static void \ kwiksort_##T(const T v[], int n, int index[], int inc, \ int index_adj, int mode, int irev) \ { \ int j; \ T##Str_t *x = NULL; \ ALLOC(x, n); \ if (mode < 10) { \ /* index[] needs to be initialized */ \ if (inc == 1) { \ for (j=0; j Fortran */ \ } \ } \ else { \ for (j=0; j Fortran */ \ } \ } \ } \ else { \ if (inc == 1) { \ for (j=0; j C */ \ x[j].valueptr = &v[tmpidx]; \ x[j].j = j; \ x[j].idx = index[j]; \ } \ } \ else { \ for (j=0; j C */ \ x[j].valueptr = &v[tmpidx * inc]; \ x[j].j = j; \ x[j].idx = index[j]; \ } \ } \ } \ qsort(x, n, sizeof(*x), \ irev ? \ (int (*)(const void *, const void *))T##cmp_rev : \ (int (*)(const void *, const void *))T##cmp); \ for (j=0; j *b ) return 1; \ else if ( *a < *b ) return -1; \ else return 0; \ } \ static int \ T##fcmp_rev(const T *a, const T *b) { \ if ( *a < *b ) return 1; \ else if ( *a > *b ) return -1; \ else return 0; \ } \ \ static void \ FastSort_##T(T v[], int n, int irev) \ { \ qsort(v, n, sizeof(*v), \ irev ? \ (int (*)(const void *, const void *))T##fcmp_rev : \ (int (*)(const void *, const void *))T##fcmp); \ } #define kwiksort(T) \ MakeKwikSort(T) \ MakeFastSort(T) #define SORT_UINT 0 kwiksort(Uint32) #define SORT_INT 1 kwiksort(Sint32) #define SORT_R64 2 kwiksort(double) #define SORT_R32 3 kwiksort(float) #define SORT_I64 4 kwiksort(Sint64) #define SORT_U64 5 kwiksort(Uint64) #define DoSort(T) { \ T *data = Data; \ { \ kwiksort_##T(&data[addr], n, index, inc, index_adj, mode, irev); \ } \ } #define DoFastSort(T) { \ T *data = Data; \ { \ FastSort_##T(data, n, irev); \ } \ } void ecqsort_(const int *Mode, const int *N, const int *Inc, const int *Start_addr, void *Data, int index[], const int *Index_adj, const int *Reverse, int *retc) { int mode = *Mode; int method = mode%10; int n = *N; int rc = n; int inc = *Inc; int index_adj = *Index_adj; int irev = *Reverse; int addr = (*Start_addr) - 1; /* Fortran to C */ if (method != SORT_UINT && method != SORT_INT && method != SORT_R64 && method != SORT_R32 && method != SORT_I64 && method != SORT_U64 ) { rc = -1; goto finish; } if (n <= 0) { if (n < 0) rc = -2; goto finish; } if (inc < 1) { rc = -3; goto finish; } switch (method) { case SORT_UINT: DoSort(Uint32); break; case SORT_INT: DoSort(Sint32); break; case SORT_R64: DoSort(double); break; case SORT_R32: DoSort(float); break; case SORT_I64: DoSort(Sint64); break; case SORT_U64: DoSort(Uint64); break; } finish: *retc = rc; } void ecqsortfast_(const int *Mode, const int *N, void *Data, const int *Reverse, int *retc) { int mode = *Mode; int method = mode%10; int n = *N; int rc = n; int irev = *Reverse; if (method != SORT_UINT && method != SORT_INT && method != SORT_R64 && method != SORT_R32 && method != SORT_I64 && method != SORT_U64 ) { rc = -1; goto finish; } if (n <= 0) { if (n < 0) rc = -2; goto finish; } switch (method) { case SORT_UINT: DoFastSort(Uint32); break; case SORT_INT: DoFastSort(Sint32); break; case SORT_R64: DoFastSort(double); break; case SORT_R32: DoFastSort(float); break; case SORT_I64: DoFastSort(Sint64); break; case SORT_U64: DoFastSort(Uint64); break; } finish: *retc = rc; } #define MakeMergeFuncs(T) \ static int \ T##_Merge(T data[], int amax, int bmax) \ { \ int i, j, N = amax + bmax; \ T *a = data; \ T *b = &data[amax]; \ i=amax-1; j=N-1; \ if (a[i] > b[0]) { \ int k; \ T *c = NULL; \ ALLOC(c, bmax); \ memcpy(c, b, bmax * sizeof(T)); \ k=bmax-1; \ while ((i >= 0) && (k >= 0)) { \ if (a[i] >= c[k]) data[j--] = a[i--]; else data[j--] = c[k--]; \ } \ while (k >= 0) data[j--] = c[k--]; \ FREE(c); \ } \ return N; \ } \ static int \ T##_MergeIdx(const T data[], int amax, int bmax, int index[], const int rank[]) \ { \ int i, j, N = amax + bmax; \ int *a = index; \ int *b = &index[amax]; \ i=amax-1; j=N-1; \ if (data[a[i]] > data[b[0]]) { \ int k; \ int *c = NULL; \ ALLOC(c, bmax); \ memcpy(c, b, bmax * sizeof(int)); \ k=bmax-1; \ while ((i >= 0) && (k >= 0)) { \ T dai = data[a[i]]; \ T dck = data[c[k]]; \ if (dai > dck) index[j--] = a[i--]; \ else if (dai < dck) index[j--] = c[k--]; \ else { /* dai == dck : the rank[] decides */ \ if (rank[a[i]] > rank[c[k]]) index[j--] = a[i--]; else index[j--] = c[k--]; \ } \ } \ while (k >= 0) index[j--] = c[k--]; \ FREE(c); \ } \ return N; \ } \ static int \ T##_Merge_rev(T data[], int amax, int bmax) \ { \ int i, j, N = amax + bmax; \ T *a = data; \ T *b = &data[amax]; \ i=amax-1; j=N-1; \ if (a[i] < b[0]) { \ int k; \ T *c = NULL; \ ALLOC(c, bmax); \ memcpy(c, b, bmax * sizeof(T)); \ k=bmax-1; \ while ((i >= 0) && (k >= 0)) { \ if (a[i] <= c[k]) data[j--] = a[i--]; else data[j--] = c[k--]; \ } \ while (k >= 0) data[j--] = c[k--]; \ FREE(c); \ } \ return N; \ } \ static int \ T##_MergeIdx_rev(const T data[], int amax, int bmax, int index[], const int rank[]) \ { \ int i, j, N = amax + bmax; \ int *a = index; \ int *b = &index[amax]; \ i=amax-1; j=N-1; \ if (data[a[i]] < data[b[0]]) { \ int k; \ int *c = NULL; \ ALLOC(c, bmax); \ memcpy(c, b, bmax * sizeof(int)); \ k=bmax-1; \ while ((i >= 0) && (k >= 0)) { \ T dai = data[a[i]]; \ T dck = data[c[k]]; \ if (dai < dck) index[j--] = a[i--]; \ else if (dai > dck) index[j--] = c[k--]; \ else { /* dai == dck : the rank[] decides */ \ if (rank[a[i]] > rank[c[k]]) index[j--] = a[i--]; else index[j--] = c[k--]; \ } \ } \ while (k >= 0) index[j--] = c[k--]; \ FREE(c); \ } \ return N; \ } MakeMergeFuncs(Uint32) MakeMergeFuncs(Sint32) MakeMergeFuncs(double) MakeMergeFuncs(float) MakeMergeFuncs(Sint64) MakeMergeFuncs(Uint64) #define DoMerge(T) { \ T *X = Data; \ X += addr; \ if (index && nidx >= n) { \ int j; \ if (index_adj) for (j=0; j C */ \ rc = irev ? \ T##_MergeIdx_rev(X, amax, bmax, index, rank) : \ T##_MergeIdx(X, amax, bmax, index, rank); \ if (index_adj) for (j=0; j Fortran */ \ } \ else { \ rc = irev ? T##_Merge_rev(X, amax, bmax) : T##_Merge(X, amax, bmax); \ } \ } void ecmerge2_(const int *Mode, const int *Start_addr, const int *Amax, const int *Bmax, void *Data, int *index, const int *Nidx, const int *Index_adj, const int *Reverse, const int rank[], int *retc) { int mode = *Mode; int method = mode%10; int addr = (*Start_addr) - 1; /* Fortran to C */ int amax = *Amax; int bmax = *Bmax; int n = amax + bmax; int nidx = *Nidx; int index_adj = *Index_adj; int irev = *Reverse; int rc = 0; if (method != SORT_UINT && method != SORT_INT && method != SORT_R64 && method != SORT_R32 && method != SORT_I64 && method != SORT_U64 ) { rc = -1; goto finish; } if (n <= 0) { if (n < 0) rc = -2; goto finish; } switch (method) { case SORT_UINT: DoMerge(Uint32); break; case SORT_INT: DoMerge(Sint32); break; case SORT_R64: DoMerge(double); break; case SORT_R32: DoMerge(float); break; case SORT_I64: DoMerge(Sint64); break; case SORT_U64: DoMerge(Uint64); break; } finish: *retc = rc; } fiat-ecmwf-2.0.0/src/fiat/ecsort/internal/rsort32.c0000664000175000017500000002246515157200431022235 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include "raise.h" /* rsort32_() : 32-bit Fortran-callable RADIX-sort */ /* by Sami Saarinen, ECMWF, 3/2/1998 - " - 1/2/2000 : BIG_ENDIAN & LITTLE_ENDIAN labels renamed to *_INDIAN since they may conflict with the ones in - " - 3/1/2001 : reference to valloc() removed; ALLOC() modified - " - 25/1/2001 : BIG_INDIAN removed (as label) LITTLE_INDIAN called as LITTLE - " - ??/9?/2001 : Speedup in rsort32 - " - 14/3/2002 : rsort32_func implemeted to enable to run alternative sorting routine than rsort32 - " - 18/02/2005 : Handle 64-bit (signed) ints IBM malloc() may call __malloc()/__free() [see getcurheap.c] - " - 21/02/2005 : Some optimization & endian detection on-the-fly - " - 07/07/2005 : Mods in index_adj & bitsum Added support for 64-bit unsigned ints - " - 07/02/2007 : Intercepting alloc (IBM & NEC SX) + NEC SX vectorization Thanks to Mike Fisher, ECMWF and Cray SCILIB ORDERS()-function developers */ /* Methods: 0 : Unsigned 32-bit ints 1 : Signed 32-bit ints 2 : 64-bit doubles (IEEE) : signbit + 11-bit exp + 52-bits mantissa 3 : 32-bit floats (IEEE) : signbit + 8-bit exp + 23-bits mantissa 4 : Signed 64-bit ints 5 : Unsigned 64-bit ints */ typedef unsigned int Uint32; typedef unsigned char Uchar; /* scalar prozezzorz */ static int SpeedUp = 1; #define SORT_UINT 0 #define SORT_INT 1 #define SORT_R64 2 #define SORT_R32 3 #define SORT_I64 4 #define SORT_U64 5 typedef long long int ll_t; #define ALLOC(x,size) \ { ll_t bytes = (ll_t)sizeof(*x) * (size); \ bytes = (bytes < 1) ? 1 : bytes; \ x = malloc(bytes); \ if (!x) { fprintf(stderr, \ "malloc() of %s (%lld bytes) failed in file=%s, line=%d\n", \ #x, bytes, __FILE__, __LINE__); RAISE(SIGABRT); } } #define FREE(x) if (x) { free(x); x = NULL; } #define BITSUM(x) bitsum[x] += ((item >> x) & 1U) #define SIGNBIT32 0x80000000 #define MASKALL32 0xFFFFFFFF #define ZEROALL32 0x00000000 #define CVMGM(a,b,c) ( ((c) & SIGNBIT32) ? (a) : (b) ) #define N32BITS 32 void rsort32_(const int *Mode, const int *N, const int *Inc, const int *Start_addr, Uint32 Data[], int index[], const int *Index_adj, int *retc) { int mode = *Mode; int method = mode%10; int n = *N; int rc = n; int inc = *Inc; int index_adj = *Index_adj; int addr = (*Start_addr) - 1; /* Fortran to C */ int i, j, jj; Uchar xorit = 0; Uchar copytmp = 0; Uchar alloc_data = 0; Uint32 *data = NULL; int *tmp = NULL; Uint32 bitsum[N32BITS]; int lsw, msw; if (method != SORT_UINT && method != SORT_INT && method != SORT_R64 && method != SORT_R32 && method != SORT_I64 && method != SORT_U64 ) { rc = -1; goto finish; } if (n <= 0) { if (n < 0) rc = -2; goto finish; } if (inc < 1) { rc = -3; goto finish; } { /* Little/big-endian selection */ extern int ec_is_little_endian(); int i_am_little = ec_is_little_endian(); if (i_am_little) { /* We are on little-endian machine */ lsw = 0; msw = 1; } else { /* We are on big-endian machine */ lsw = 1; msw = 0; } } if (method == SORT_R64 || method == SORT_I64 || method == SORT_U64) { inc *= 2; addr *= 2; } if (mode < 10) { /* index[] needs to be initialized */ for (i=0; i 1) || (method == SORT_R32) || (method == SORT_R64) || (method == SORT_I64) || (method == SORT_U64) ); if (alloc_data) ALLOC(data, n); if (method == SORT_R32) { j = addr; for (i=0; i 1) { j = addr; for (i=0; i 0 && sum < n) { /* if 0 or n, then the whole column of bits#j 0's or 1's */ Uint32 mask = (1U << j); int *i1, *i2; if (jj%2 == 0) { i1 = index; i2 = tmp; copytmp = 1; } else { i1 = tmp; i2 = index; copytmp = 0; } if (SpeedUp == 0) { int k = 0; for (i=0; i /* gnomesort.c : The easiest sort on Earth ? Yes, it is. This is how a Dutch Garden Gnome sorts a line of flower pots. Basically, he looks at the flower pot next to him and the previous one; if they are in the right order he steps one pot forward, otherwise he swaps them and steps one pot backwards. Boundary conditions: if there is no previous pot, he steps forwards; if there is no pot next to him, he is done. See more Wikipedia & http://www.cs.vu.nl/~dick/gnomesort.html Author: Sami Saarinen, ECMWF, 12-Nov-2007 */ /* Fortran callable: ecgnomesort_() */ /* Methods: 0 : Unsigned 32-bit ints 1 : Signed 32-bit ints 2 : 64-bit doubles (IEEE) : signbit + 11-bit exp + 52-bits mantissa 3 : 32-bit floats (IEEE) : signbit + 8-bit exp + 23-bits mantissa 4 : Signed 64-bit ints 5 : Unsigned 64-bit ints */ typedef unsigned long long int Uint64; typedef long long int Sint64; typedef unsigned int Uint32; typedef int Sint32; #define GnomeSort(T) \ static void GnomeSort_##T(T a[], const int n, const int inc) \ { \ int i = 0; \ if (inc == 1) { \ while (i < n) { \ if (i == 0 || a[i-1] <= a[i]) ++i; \ else {T tmp = a[i]; a[i] = a[i-1]; a[--i] = tmp;} \ } \ } else { \ while (i < n) { \ if (i == 0 || a[(i-1)*inc] <= a[i*inc]) ++i; \ else {T tmp = a[i*inc]; a[i*inc] = a[(i-1)*inc]; a[(--i)*inc] = tmp;} \ } \ } \ } \ static void GnomeSortIdx_##T(const T a[], const int n, const int inc, int index[], const int index_adj) \ { \ int i = 0; \ if (inc == 1) { \ if (index_adj) { \ while (i < n) { \ if (i == 0 || a[index[i-1]-index_adj] <= a[index[i]-index_adj]) ++i; \ else {int tmp = index[i]; index[i] = index[i-1]; index[--i] = tmp;} \ } \ } else { /* index_adj == 0 */ \ while (i < n) { \ if (i == 0 || a[index[i-1]] <= a[index[i]]) i++; \ else {int tmp = index[i]; index[i] = index[i-1]; index[--i] = tmp;} \ } \ } \ } else { /* inc != 1 */ \ if (index_adj) { \ while (i < n) { \ if (i == 0 || a[(index[i-1]-index_adj)*inc] <= a[(index[i]-index_adj)*inc]) ++i; \ else {int tmp = index[i]; index[i] = index[i-1]; index[--i] = tmp;} \ } \ } else { /* index_adj == 0 */ \ while (i < n) { \ if (i == 0 || a[index[i-1]*inc] <= a[index[i]*inc]) ++i; \ else {int tmp = index[i]; index[i] = index[i-1]; index[--i] = tmp;} \ } \ } \ } \ } #define DoSort(T) { \ T *data = Data; \ if (index && nidx >= n) { \ GnomeSortIdx_##T(&data[addr], n, inc, index, index_adj); \ } else { \ GnomeSort_##T(&data[addr], n, inc); \ } \ } #define SORT_UINT 0 GnomeSort(Uint32) #define SORT_INT 1 GnomeSort(Sint32) #define SORT_R64 2 GnomeSort(double) #define SORT_R32 3 GnomeSort(float) #define SORT_I64 4 GnomeSort(Sint64) #define SORT_U64 5 GnomeSort(Uint64) void ecgnomesort_(const int *Mode, const int *N, const int *Inc, const int *Start_addr, void *Data, int *index, const int *Nindex, const int *Index_adj, int *retc) { int mode = *Mode; int method = mode%10; int n = *N; int rc = n; int inc = *Inc; int nidx = *Nindex; /* Must be >= n or otherwise the index[] is disregarded */ int index_adj = *Index_adj; int addr = (*Start_addr) - 1; /* Fortran to C */ if (method != SORT_UINT && method != SORT_INT && method != SORT_R64 && method != SORT_R32 && method != SORT_I64 && method != SORT_U64 ) { rc = -1; goto finish; } if (n <= 0) { if (n < 0) rc = -2; goto finish; } if (inc < 1) { rc = -3; goto finish; } switch (method) { case SORT_UINT: DoSort(Uint32); break; case SORT_INT: DoSort(Sint32); break; case SORT_R64: DoSort(double); break; case SORT_R32: DoSort(float); break; case SORT_I64: DoSort(Sint64); break; case SORT_U64: DoSort(Uint64); break; } finish: *retc = rc; } fiat-ecmwf-2.0.0/src/fiat/ecsort/internal/countingsort.c0000664000175000017500000002273415157200431023454 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include "raise.h" /* ec_countingsort_() : Fortran-callable counting-sort */ /* by Sami Saarinen, ECMWF, 01/11/2007 : 1st working version Algorithm derived from C++ implementation in Wikipedia However, the index[]'ed version added by ourselves. */ /* Methods: 0 : Unsigned 32-bit ints 1 : Signed 32-bit ints 2 : 64-bit doubles (IEEE) : signbit + 11-bit exp + 52-bits mantissa 3 : 32-bit floats (IEEE) : signbit + 8-bit exp + 23-bits mantissa 4 : Signed 64-bit ints 5 : Unsigned 64-bit ints */ #define SORT_UINT 0 #define SORT_INT 1 #define SORT_R64 2 #define SORT_R32 3 #define SORT_I64 4 #define SORT_U64 5 typedef unsigned long long int Uint64; typedef long long int Sint64; typedef unsigned int Uint32; typedef int Sint32; typedef long long int ll_t; typedef unsigned long long int u_ll_t; #define ALLOC(x,size) \ { ll_t bytes = (ll_t)sizeof(*x) * (size); \ bytes = (bytes < 1) ? 1 : bytes; \ x = malloc(bytes); \ if (!x) { fprintf(stderr, \ "malloc() of %s (%lld bytes) failed in file=%s, line=%d\n", \ #x, bytes, __FILE__, __LINE__); RAISE(SIGABRT); } } #define CALLOC(x,size) \ { ll_t sz = (ll_t)(size); \ sz = (sz < 1) ? 1 : sz; \ x = calloc(sz, sizeof(*x)); \ if (!x) { ll_t bytes = (ll_t)sizeof(*x) * (sz); \ fprintf(stderr, \ "calloc() of %s (%lld bytes) failed in file=%s, line=%d\n", \ #x, bytes, __FILE__, __LINE__); RAISE(SIGABRT); } } #define FREE(x) if (x) { free(x); x = NULL; } #ifdef DEBUG #define AZZERT(cond) if (cond) ABOR1("Azzertion failed: "#cond) #else #define AZZERT(cond) #endif /* Applicable for 32-bits only */ #define SIGNBIT32 0x80000000u #define MASKALL32 0xFFFFFFFFu #define CVMGM32(a,b,c) ( ((c) & SIGNBIT32) ? (a) : (b) ) static const int Npasses32 = 2; /* i.e. 2 x 16-bit passes == 32-bits */ /* Applicable for 64-bits only */ #define SIGNBIT64 0x8000000000000000ull #define MASKALL64 0xFFFFFFFFFFFFFFFFull #define CVMGM64(a,b,c) ( ((c) & SIGNBIT64) ? (a) : (b) ) static const int Npasses64 = 4; /* i.e. 4 x 16-bit passes == 64-bits */ /* CountingSort */ #define MASKALL16 0xFFFF #define NCOUNT (MASKALL16+1) typedef struct { int *sorted; int counts[NCOUNT]; } cs_shared_t; #define FOR(i,s,e) for (i = s; i < e; ++i) #define SHIFTMASK(a,shift) ((int)(((a) >> shift) & mask)) #define CntSort(T,NB,shift,idummy) \ static void \ CSortSM##shift##NB(const T A[], const int n, int local_index[], \ const T idummy, cs_shared_t *cs, const int irev) \ { /* Note: A[] is a contiguous, stride=1, local data -- a shade copy of the original "void *Data"-array */ \ const T mask = MASKALL16; \ int i, tmp, nr, min = MASKALL16, max = min; \ FOR(i,0,n) { \ tmp = SHIFTMASK(A[i],shift); if (tmp < min) min = tmp; else if (tmp > max) max = tmp; \ } \ nr = max - min + 1; \ AZZERT(nr <= 0 || nr > NCOUNT); \ if (nr > 1) { /* i.e. max > min */ \ /* nr == 1 would have meant that all values were equal --> skip */ \ int j, icnt; \ int *counts = cs->counts; \ memset(counts, 0, nr * sizeof(*counts)); \ if (irev) { /* Reverse, descending order */ \ FOR(i,0,n) { tmp = max - SHIFTMASK(A[i],shift); AZZERT(tmp < 0 || tmp >= NCOUNT); ++counts[ tmp ]; } \ } \ else { /* Ascending order */ \ FOR(i,0,n) { tmp = SHIFTMASK(A[i],shift) - min; AZZERT(tmp < 0 || tmp >= NCOUNT); ++counts[ tmp ]; } \ } \ /* Cascade counts to get cumulative counts */ \ FOR(j,1,nr) counts[j] += counts[j-1]; \ { \ int *sorted = cs->sorted; \ if (!sorted) { ALLOC(sorted, n); cs->sorted = sorted; } \ if (irev) { /* Reverse, descending order */ \ for (i = n-1; i >= 0; --i) { \ j = local_index[i]; \ tmp = max - SHIFTMASK(A[j],shift); AZZERT(tmp < 0 || tmp >= NCOUNT); \ icnt = --counts[ tmp ]; AZZERT(icnt < 0 || icnt >= n); \ sorted[icnt] = j; \ } \ } \ else { /* Ascending order */ \ for (i = n-1; i >= 0; --i) { \ j = local_index[i]; \ tmp = SHIFTMASK(A[j],shift) - min; AZZERT(tmp < 0 || tmp >= NCOUNT); \ icnt = --counts[ tmp ]; AZZERT(icnt < 0 || icnt >= n); \ sorted[icnt] = j; \ } \ } \ memcpy(local_index, sorted, n * sizeof(int)); \ } \ } /* if (nr > 1) */ \ } #define Helpers(T,NB) \ static T * \ signmask##NB(const T Data[], int n, int inc, const int *index, int index_adj) \ { \ T *A = NULL; \ int i; \ ALLOC(A, n); \ if (index && index_adj == 0) { \ if (inc == 1) { \ FOR(i,0,n) { \ int j = index[i]; \ T mask = CVMGM##NB(MASKALL##NB, SIGNBIT##NB, Data[j]); \ A[i] = Data[j] ^ mask; \ } \ } else { \ FOR(i,0,n) { \ int j = index[i]*inc; \ T mask = CVMGM##NB(MASKALL##NB, SIGNBIT##NB, Data[j]); \ A[i] = Data[j] ^ mask; \ } \ } \ } \ else if (index) { \ if (inc == 1) { \ FOR(i,0,n) { \ int j = (index[i] - index_adj); \ T mask = CVMGM##NB(MASKALL##NB, SIGNBIT##NB, Data[j]); \ A[i] = Data[j] ^ mask; \ } \ } else { \ FOR(i,0,n) { \ int j = (index[i] - index_adj)*inc; \ T mask = CVMGM##NB(MASKALL##NB, SIGNBIT##NB, Data[j]); \ A[i] = Data[j] ^ mask; \ } \ } \ } else { \ if (inc == 1) { \ FOR(i,0,n) { \ T mask = CVMGM##NB(MASKALL##NB, SIGNBIT##NB, Data[i]); \ A[i] = Data[i] ^ mask; \ } \ } else { \ FOR(i,0,n) { \ int j = i*inc; \ T mask = CVMGM##NB(MASKALL##NB, SIGNBIT##NB, Data[j]); \ A[i] = Data[j] ^ mask; \ } \ } \ } \ return A; \ } \ static T * \ justcopy##NB(const T Data[], int n, int inc, const int *index, int index_adj) \ { \ T *A = NULL; \ int i; \ ALLOC(A, n); \ if (index && index_adj == 0) { \ if (inc == 1) { \ FOR(i,0,n) A[i] = Data[index[i]]; \ } else { \ FOR(i,0,n) A[i] = Data[index[i]*inc]; \ } \ } \ else if (index) { \ if (inc == 1) { \ FOR(i,0,n) A[i] = Data[(index[i]-index_adj)]; \ } else { \ FOR(i,0,n) A[i] = Data[(index[i]-index_adj)*inc]; \ } \ } \ else { \ if (inc == 1) { \ memcpy(A, Data, n * sizeof(T)); \ } else { \ FOR(i,0,n) A[i] = Data[i*inc]; \ } \ } \ return A; \ } \ static void \ sorted##NB(T Data[], int n, int inc, const int local_index[], T work[]) \ { \ int i; \ if (inc == 1) { \ FOR(i,0,n) work[i] = Data[local_index[i]]; \ memcpy(Data, work, n * sizeof(T)); \ } \ else { \ FOR(i,0,n) work[i] = Data[local_index[i]*inc]; \ FOR(i,0,n) Data[i * inc] = work[i]; \ } \ } static int * CreateIndex(int n) { int *local_index = NULL; int i; ALLOC(local_index, n); FOR(i,0,n) local_index[i] = i; return local_index; } static void Local2GlobalIndex(int n, const int local_index[], int index[], void *work) { int i; int *tmpidx = work; FOR(i,0,n) { int lc = local_index[i]; AZZERT(lc < 0 || lc >= n); tmpidx[i] = index[lc]; } memcpy(index, tmpidx, n * sizeof(*index)); } CntSort(Uint32,32,0,idummy) CntSort(Uint32,32,shift,shift) Helpers(Uint32,32) CntSort(Uint64,64,0,idummy) CntSort(Uint64,64,shift,shift) Helpers(Uint64,64) #define DoSort(T,copyfun,NB) { \ int j; \ int Npasses = Npasses##NB; \ int *local_index = NULL; \ T *data = Data; \ T *dada = copyfun(&data[addr], n, inc, index, index ? index_adj : 0); \ T shift = 0; \ cs_shared_t cs; \ cs.sorted = NULL; \ local_index = CreateIndex(n); \ CSortSM0##NB(dada, n, local_index, shift, &cs, irev); \ for (j=1; j= n or otherwise the index[] is disregarded */ int index_adj = *Index_adj; int irev = *Reverse; if (n <= 0) goto finish; if (nidx < n) index = NULL; switch (method) { case SORT_UINT: DoSort(Uint32,justcopy32,32); break; case SORT_INT: DoSort(Uint32,signmask32,32); break; case SORT_R64: DoSort(Uint64,signmask64,64); break; case SORT_R32: DoSort(Uint32,signmask32,32); break; case SORT_I64: DoSort(Uint64,signmask64,64); break; case SORT_U64: DoSort(Uint64,justcopy64,64); break; default: rc = -1; break; } finish: *retc = rc; } fiat-ecmwf-2.0.0/src/fiat/ecsort/ecsort_mix.F900000664000175000017500000002777415157200431021403 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE ECSORT_MIX USE EC_PARKIND , ONLY : JPIM ,JPIB, JPRM ,JPRD USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK USE OML_MOD , ONLY : OML_MAX_THREADS, OML_MY_THREAD, OML_IN_PARALLEL USE STRHANDLER_MOD, ONLY : TOUPPER USE MPL_MODULE , ONLY : MPL_MYRANK, MPL_NPROC !$ !.. Author: Sami Saarinen, ECMWF, 10/02/98 ! Fixes : Sami Saarinen, ECMWF, 08/11/99 : Sub-arrays go now correctly (look for addrdiff) ! Genuine real(4) sort "re-habilitated" ! sizeof_int, _real4 & _real8 HARDCODED ! ! Sami Saarinen, ECMWF, 11/10/00 : REAL*4 version included (REAL_M) ! Sami Saarinen, ECMWF, 28/11/03 : Calls to DR_HOOK added manually (on top of CY28) ! Sami Saarinen, ECMWF, 18/02/05 : 64-bit integer sorting introduced (for CY30) ! Sami Saarinen, ECMWF, 22/02/05 : Using genuine 64-bit rsort64() => one-pass through data ! Sami Saarinen, ECMWF, 06/07/05 : "current_method" made OpenMP-thread aware (for max. # of threads = NTHRDS) ! Sami Saarinen, ECMWF, 07/07/05 : Quick-sort method finally arrived (and applicable to multikeys, too) ! Quick-sort the default for scalar machines ("non-VPP"), VPPs is radix-sort ! Sami Saarinen, ECMWF, 03/07/07 : Quick-sort method uses stable approach (was not guaranteed so before) ! Sami Saarinen, ECMWF, 15/10/07 : Subroutines put into a common file ../include/ecsort_shared.h and ! preprocessed from there ! Sami Saarinen, ECMWF, 15/10/07 : NTHRDS increased from 32 to 64 ! Sami Saarinen, ECMWF, 16/10/07 : The default sorting method can be overriden via export EC_SORTING_METHOD=[|] ! Sami Saarinen, ECMWF, 30/10/07 : Support for CountingSort added as part of QuickSort speedup ! Sami Saarinen, ECMWF, 31/10/07 : CALL SORTING_METHOD() now prints the prevailing method from EC_SORTING_METHOD ! Sami Saarinen, ECMWF, 01/11/07 : CountingSort implemented as independent method ! Sami Saarinen, ECMWF, 06/11/07 : index_adj added as an optional argument to init_index ; new routine adjust_index() ! Sami Saarinen, ECMWF, 07/11/07 : threshold length "nomp" (see below). Override with EC_SORTING_NOMP. ! Sami Saarinen, ECMWF, 12/11/07 : Gnome-sort -- the easiest sort on Earth (and very slow for large arrays) ! Sami Saarinen, ECMWF, 15/11/07 : OpenMP-sorting still under development. Do NOT override the EC_SORTING_NOMP yet. ! Sami Saarinen, ECMWF, 05/12/07 : When export EC_SORTING_INFO=0, then no info messages are printed from CALL sorting_method() ! Sami Saarinen, ECMWF, 20/12/07 : export EC_SORTING_INFO=0, rather than =1 is now the default --> less hassling output IMPLICIT NONE SAVE PRIVATE INTEGER(KIND=JPIM), PARAMETER :: NTHRDS = 64 ! ***Note: A hardcoded max number of threads !!! INTEGER(KIND=JPIM), PARAMETER :: SIZEOF_INT4 = 4 INTEGER(KIND=JPIM), PARAMETER :: SIZEOF_INT8 = 8 INTEGER(KIND=JPIM), PARAMETER :: SIZEOF_REAL4 = 4 INTEGER(KIND=JPIM), PARAMETER :: SIZEOF_REAL8 = 8 INTEGER(KIND=JPIM), PARAMETER :: MIN_METHOD = 1 INTEGER(KIND=JPIM), PARAMETER :: MAX_METHOD = 5 INTEGER(KIND=JPIM), PARAMETER :: RADIXSORT_METHOD = 1 INTEGER(KIND=JPIM), PARAMETER :: HEAPSORT_METHOD = 2 INTEGER(KIND=JPIM), PARAMETER :: QUICKSORT_METHOD = 3 INTEGER(KIND=JPIM), PARAMETER :: COUNTINGSORT_METHOD = 4 INTEGER(KIND=JPIM), PARAMETER :: GNOMESORT_METHOD = 5 CHARACTER(LEN=12), PARAMETER :: METHOD_NAME(MIN_METHOD:MAX_METHOD) = & & (/& & 'RADIXSORT ' & & ,'HEAPSORT ' & & ,'QUICKSORT ' & & ,'COUNTINGSORT' & & ,'GNOMESORT ' & & /) !-- Select such method for default_method, which also works for multikey sorts ! Vector machines should choose radixsort_method, others quicksort_method (oh, sorry, countingsort_method!) ! ! Note: Occasionally radixsort_method may be faster on non-vector machines, too INTEGER(KIND=JPIM) :: DEFAULT_METHOD = COUNTINGSORT_METHOD INTEGER(KIND=JPIM) :: CURRENT_METHOD(NTHRDS) = COUNTINGSORT_METHOD !-- A threshold length after which OpenMP in sorting, merging, copying may kick in. ! Override with EC_SORTING_NOMP. Detected while initializing/calling SORTING_METHOD ! Non-positive values (<= 0) indicate that OpenMP will NOT be attempted at all INTEGER(KIND=JPIM) :: NOMP = -1 !-- EC_SORTING_INFO = MPL-proc id [1..$NPES] to print the info message when CALL sorting_method() ! : 0 (no print; the default) ! : 1 (print on MPL-task one) ! : > 1 and <= $NPES (some other MPL-task than 1 prints) INTEGER(KIND=JPIM) :: NSINFO = 0 INTERFACE KEYSORT MODULE PROCEDURE & &INT4_KEYSORT_1D, INT4_KEYSORT_2D, & &INT8_KEYSORT_1D, INT8_KEYSORT_2D, & &REAL8_KEYSORT_1D, REAL8_KEYSORT_2D, & &REAL4_KEYSORT_1D, REAL4_KEYSORT_2D END INTERFACE INTERFACE SORTING_METHOD MODULE PROCEDURE INT_SORTING_METHOD, STR_SORTING_METHOD END INTERFACE PUBLIC :: KEYSORT PUBLIC :: INIT_INDEX, GET_RANK, ADJUST_INDEX PUBLIC :: SORTING_METHOD PUBLIC :: RADIXSORT_METHOD, HEAPSORT_METHOD, QUICKSORT_METHOD PUBLIC :: COUNTINGSORT_METHOD, GNOMESORT_METHOD CONTAINS !---------------------------- !-- Public subroutines -- !---------------------------- SUBROUTINE INT_SORTING_METHOD(INEW, IOLD) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: INEW INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: IOLD INTEGER(KIND=JPIM) :: ITMP, IMYPROC, INPES INTEGER(KIND=JPIM) :: ITID CHARACTER(LEN=20) CLENV LOGICAL, SAVE :: LLFIRST = .TRUE. LOGICAL LLOMP, LLHOOK_OK REAL(KIND=JPHOOK) :: ZHOOK_HANDLE !-- This maybe called from the very first call of DR_HOOK_UTIL ... LLHOOK_OK = LHOOK .AND. (PRESENT(INEW) .OR. PRESENT(IOLD)) IF (LLHOOK_OK) CALL DR_HOOK('ECSORT_MIX:INT_SORTING_METHOD',0,ZHOOK_HANDLE) ITID = OML_MY_THREAD() LLOMP = OML_IN_PARALLEL() IF (PRESENT(IOLD)) IOLD = CURRENT_METHOD(ITID) ITMP = -1 IF (PRESENT(INEW)) THEN ITMP = INEW ELSE IF (.NOT.LLOMP) THEN ! Override the default method (only if outside the OpenMP) ITMP = -1 ! no change IF (LLFIRST) THEN ! Do once per execution only INPES = MPL_NPROC() CALL GET_ENVIRONMENT_VARIABLE('EC_SORTING_INFO',CLENV) ! ../support/env.c IF (CLENV /= ' ') THEN ITMP = NSINFO READ(CLENV,'(i20)',END=89,ERR=89) ITMP GOTO 88 89 CONTINUE ITMP = NSINFO ! no change 88 CONTINUE IF (ITMP <= 0) THEN NSINFO = 0 ELSE IF (ITMP >= 1 .AND. ITMP <= INPES) THEN NSINFO = ITMP ENDIF ENDIF IMYPROC = MPL_MYRANK() CALL GET_ENVIRONMENT_VARIABLE('EC_SORTING_METHOD',CLENV) ! ../support/env.c IF (CLENV /= ' ') THEN IF (IMYPROC == NSINFO) WRITE(0,'(a)')' MAX_METHOD) ITMP = DEFAULT_METHOD DEFAULT_METHOD = ITMP CURRENT_METHOD(:) = ITMP IF (IMYPROC == NSINFO) & & WRITE(0,'(a,i1,a)')'>EC_SORTING_METHOD=',DEFAULT_METHOD,& & ' # '//METHOD_NAME(DEFAULT_METHOD) CALL GET_ENVIRONMENT_VARIABLE('EC_SORTING_NOMP',CLENV) IF (CLENV /= ' ') THEN IF (IMYPROC == NSINFO) WRITE(0,'(a)')'EC_SORTING_NOMP='//TRIM(ADJUSTL(CLENV)) ENDIF ITMP = DEFAULT_METHOD LLFIRST = .FALSE. ENDIF ENDIF IF (ITMP < MIN_METHOD .OR. ITMP > MAX_METHOD) ITMP = DEFAULT_METHOD IF (LLOMP) THEN ! Only this thread sees the change CURRENT_METHOD(ITID) = ITMP ELSE ! All threads see the change CURRENT_METHOD(:) = ITMP ENDIF IF (LLHOOK_OK) CALL DR_HOOK('ECSORT_MIX:INT_SORTING_METHOD',1,ZHOOK_HANDLE) END SUBROUTINE INT_SORTING_METHOD SUBROUTINE STR_SORTING_METHOD(CDNEW, IOLD) CHARACTER(LEN=*), INTENT(IN) :: CDNEW INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: IOLD CHARACTER(LEN=LEN(CDNEW)) CLNEW REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:STR_SORTING_METHOD',0,ZHOOK_HANDLE) CLNEW = CDNEW CALL TOUPPER(CLNEW) SELECT CASE (CLNEW) CASE ('RADIX', 'RADIXSORT') CALL SORTING_METHOD(RADIXSORT_METHOD, IOLD) CASE ('HEAP', 'HEAPSORT') CALL SORTING_METHOD(HEAPSORT_METHOD, IOLD) CASE ('QUICK', 'QUICKSORT', 'QSORT') CALL SORTING_METHOD(QUICKSORT_METHOD, IOLD) CASE ('COUNT', 'COUNTINGSORT', 'COUNTSORT') CALL SORTING_METHOD(COUNTINGSORT_METHOD, IOLD) CASE ('GNOME', 'GNOMESORT') CALL SORTING_METHOD(GNOMESORT_METHOD, IOLD) CASE ('DEFAULT', 'DEF') CALL SORTING_METHOD(DEFAULT_METHOD, IOLD) CASE DEFAULT CALL SORTING_METHOD(DEFAULT_METHOD, IOLD) END SELECT IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:STR_SORTING_METHOD',1,ZHOOK_HANDLE) END SUBROUTINE STR_SORTING_METHOD SUBROUTINE INIT_INDEX(INDEX, INDEX_ADJ) INTEGER(KIND=JPIM), INTENT(OUT):: INDEX(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: INDEX_ADJ INTEGER(KIND=JPIM) :: I, N REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:INIT_INDEX',0,ZHOOK_HANDLE) N = SIZE(INDEX) IF (PRESENT(INDEX_ADJ)) THEN DO I=1,N INDEX(I) = I + INDEX_ADJ ENDDO ELSE DO I=1,N INDEX(I) = I ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:INIT_INDEX',1,ZHOOK_HANDLE) END SUBROUTINE INIT_INDEX SUBROUTINE ADJUST_INDEX(INDEX, INDEX_ADJ) INTEGER(KIND=JPIM), INTENT(INOUT):: INDEX(:) INTEGER(KIND=JPIM), INTENT(IN) :: INDEX_ADJ INTEGER(KIND=JPIM) :: I, N REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:ADJUST_INDEX',0,ZHOOK_HANDLE) IF (INDEX_ADJ /= 0) THEN N = SIZE(INDEX) DO I=1,N INDEX(I) = INDEX(I) + INDEX_ADJ ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:ADJUST_INDEX',1,ZHOOK_HANDLE) END SUBROUTINE ADJUST_INDEX SUBROUTINE GET_RANK(INDEX, RANK, INDEX_ADJ) INTEGER(KIND=JPIM), INTENT(IN) :: INDEX(:) INTEGER(KIND=JPIM), INTENT(OUT):: RANK(:) INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: INDEX_ADJ INTEGER(KIND=JPIM) :: I, N REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:GET_RANK',0,ZHOOK_HANDLE) N = MIN(SIZE(INDEX),SIZE(RANK)) IF (PRESENT(INDEX_ADJ)) THEN DO I=1,N RANK(INDEX(I)+INDEX_ADJ) = I ENDDO ELSE DO I=1,N RANK(INDEX(I)) = I ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('ECSORT_MIX:GET_RANK',1,ZHOOK_HANDLE) END SUBROUTINE GET_RANK #undef INT_VERSION #undef REAL_VERSION !-- Create version for INTEGER(KIND=JPIM) #define INT_VERSION 4 #define REAL_VERSION 0 #include "ecsort_shared.h" #undef INT_VERSION #undef REAL_VERSION !-- Create version for INTEGER(KIND=JPIB) #define INT_VERSION 8 #define REAL_VERSION 0 #include "ecsort_shared.h" #undef INT_VERSION #undef REAL_VERSION !-- Create version for REAL(KIND=JPRM) #define INT_VERSION 0 #define REAL_VERSION 4 #include "ecsort_shared.h" #undef INT_VERSION #undef REAL_VERSION !-- Create version for REAL(KIND=JPRD) #define INT_VERSION 0 #define REAL_VERSION 8 #include "ecsort_shared.h" #undef INT_VERSION #undef REAL_VERSION END MODULE ECSORT_MIX fiat-ecmwf-2.0.0/src/fiat/oml/0000775000175000017500000000000015157200431016216 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/oml/oml_mod.F900000664000175000017500000004525115157200431020133 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE OML_MOD !-- the following system specific omp_lib-module is not always available (e.g. pgf90) !! use omp_lib USE EC_PARKIND ,ONLY : JPIM, JPIB USE EC_LUN, ONLY : NULERR !**SS/18-Feb-2005 !--Dr.Hook references removed, because these locks may also be ! called from within drhook.c itself !! !--Also, there could be considerable & unjustified overhead ! when using Dr.Hook in such a low level !**SS/15-Dec-2005 !--The size of lock-variables are now OMP_LOCK_KIND as of in OMP_LIB, ! and OMP_LOCK_KIND is aliased to OML_LOCK_KIND ! OMP_LOCK_KIND is usually 4 in 32-bit addressing mode ! 8 in 64-bit addressing mode !--M_OML_LOCK changed to M_EVENT and kept as 32-bit int !--OML_FUNCT changed to OML_TEST_EVENT !--M_LOCK initialized to -1 !--M_EVENT initialized to 0 !--Added intent(s) !--Support for omp_lib (but not always available) !--Locks can now also be set/unset OUTSIDE the parallel regions !--Added routine OML_TEST_LOCK (attempts to set lock, but if *un*successful, does NOT block) !--Buffer-zone for M_LOCK; now a vector of 2 elements in case problems/inconsistencies with OMP_LOCK_KIND 4/8 !**SS/22-Feb-2006 !--Locking routines are doing nothing unless OMP_GET_MAX_THREADS() > 1 ! This is to avoid unacceptable deadlocks/timeouts with signal handlers when ! the only thread receives signal while inside locked region !--Affected routines: OML_TEST_LOCK() --> always receives .TRUE. ! OML_SET_LOCK() --> sets nothing ! OML_UNSET_LOCK() --> unsets nothing ! OML_INIT_LOCK() --> inits nothing !**SS/11-Sep-2006 !--Added OML_DEBUG feature !**REK/18-Jul-2007 !--Protected OML_DESTROY_LOCK !**REK/07-Sep-2007 !--Add OMP FLUSH feature !**SS/05-Dec-2007 !--Added routine OML_NUM_THREADS([optional_new_number_of_threads]) ! 1) To adjust [reduce] the number of threads working in concert ! Accepts only # of threads between 1 and the max # of threads (i.e. from export OMP_NUM_THREADS=) ! 2) Returns the previous active number of threads ! 3) Can be called from outside the OpenMP-parallel region only !**SS/14-Dec-2007 !--The routine OML_NUM_THREADS() now also accepts character string (= environment variable) ! as the sole argumentoz !--You could now set effective number of threads (<= $OMP_NUM_THREADS) to the value of ! particular environment variable; f.ex.: ! export OML_MSGPASS_OBSDATA_READ=8 and call to OML_NUM_THREADS('OML_MSGPASS_OBSDATA_READ') ! would set the effective no. of threads to (max) 8 when reading obs. wiz msgpass_obsdata !**SS/09-May-2008 !-- OML_NUM_THREADS() did not work as expected since I misinterpreted the meaning of ! the OpenMP-function OMP_GET_NUM_THREADS() !-- With two PRIVATE [to this module] variables the bug will get sorted out ! + a new routine OML_INIT() was added (to be called from MPL_INIT or so) !**FV/27-May-2009 !-- OML_GET_NUM_THREADS() !**FV/09-Oct-2018 !-- OML_INCR_COUNTER to increment and check before launching synchronization !**Willem Deconinck/02-Feb-2022 !-- Deprecate OML_GET_NUM_THREADS() and remove overloads as they were not used ! Use OML_GET_MAX_THREADS instead. !-- Initialize OML_ABSMAX_THREADS within OML_INIT and abort if OML_INIT was forgotten ! before accessing OML_ABSMAX_THREADS !**Sami Saarinen/19-Feb-2022 !-- Final clean-ups & fixes for this module !:: Rename (and bring back) OML_NUM_THREADS() as OML_SET_NUM_THREADS() !:: Bring back OML_GET_NUM_THREADS() == the *actual* number of threads WHEN IN a parallel region (otherwise == 1) !:: The OML_GET_MAX_THREADS() is the *currently* available max threads, which could go up|down ! if OML|OMP_SET_NUM_THREADS() was called explicitly (NOT recommended -- messes up thread affinity) !:: Got rid of the confusing OML_ABSMAX_THREADS() -- instead relying solely on OML_MAX_THREADS() ! Now N_OML_MAX_THREADS holds the max allowed value (upon OML_INIT()) ! this variable never changes and *should* be the high water mark for number of threads ever per run ! equivalent to the value of "export OMP_NUM_THREADS=" or the system shell default; e.g. that of "nproc --all" ! Caveat & warning: User may still increase beyond the N_OML_MAX_THREADS by explicitly calling OMP_SET_NUM_THREADS() !!! !:: OML_GET_MAX_THREADS() is now an alias to OML_MAX_THREADS() !:: OML_INIT()'s initialization of N_OML_MAX_THREADS only done if OUTSIDE the parallel region -- otherwise task aborted IMPLICIT NONE SAVE PRIVATE LOGICAL :: OML_DEBUG = .FALSE. INTERFACE OML_SET_NUM_THREADS MODULE PROCEDURE & & OML_SET_NUM_THREADS_INT, & & OML_SET_NUM_THREADS_STR END INTERFACE OML_SET_NUM_THREADS INTERFACE OML_GET_MAX_THREADS MODULE PROCEDURE & & OML_MAX_THREADS END INTERFACE OML_GET_MAX_THREADS PUBLIC OML_WAIT_EVENT, OML_SET_EVENT, OML_INCR_EVENT, & & OML_MY_THREAD, OML_MAX_THREADS , OML_GET_MAX_THREADS, OML_OMP, & & OML_IN_PARALLEL, OML_TEST_EVENT, OML_INCR_COUNTER, & & OML_UNSET_LOCK, OML_INIT_LOCK, OML_SET_LOCK, OML_DESTROY_LOCK, & & OML_LOCK_KIND, OML_TEST_LOCK, OML_DEBUG, OML_SET_NUM_THREADS, & & OML_INIT, OML_GET_NUM_THREADS !-- The following should normally be 4 in 32-bit addressing mode ! 8 in 64-bit addressing mode ! Since system specific omp_lib-module is not always available (e.g. pgf90) ! we hardcode OML_LOCK_KIND to JPIB (usually 8) for now !!INTEGER(KIND=JPIM), PARAMETER :: OML_LOCK_KIND = OMP_LOCK_KIND INTEGER(KIND=JPIM), PARAMETER :: OML_LOCK_KIND = JPIB !-- Note: Still JPIM !! INTEGER(KIND=JPIM) :: M_EVENT = 0 !-- Note: OML_LOCK_KIND, not JPIM !! INTEGER(KIND=OML_LOCK_KIND) :: M_LOCK(2) = (/-1, -1/) !-- The two PRIVATE [to this module] variables INTEGER(KIND=JPIM) :: N_OML_MAX_THREADS = -1 !-- OMP function declarations (that require knowledge of their type) now in one place: #include "abor1.intfb.h" ! Define interface of call-back routine. ABSTRACT INTERFACE SUBROUTINE OML_PARALLEL_FUNCTION (ARGS) BIND(C) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_PTR TYPE(C_PTR), VALUE :: ARGS END SUBROUTINE OML_PARALLEL_FUNCTION END INTERFACE CONTAINS SUBROUTINE OML_INIT() CHARACTER(LEN=*), PARAMETER :: CLMSG = 'Fatal coding error : Cannot CALL OML_INIT() INSIDE the OpenMP parallel region' !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ LOGICAL :: OMP_IN_PARALLEL IF (N_OML_MAX_THREADS == -1) THEN IF (OML_IN_PARALLEL()) THEN WRITE(NULERR,'(1X,A)') CLMSG CALL ABOR1(CLMSG) RETURN ENDIF N_OML_MAX_THREADS = 1 !$ N_OML_MAX_THREADS = OMP_GET_MAX_THREADS() ENDIF END SUBROUTINE OML_INIT FUNCTION OML_OMP() LOGICAL :: OML_OMP OML_OMP=.FALSE. !$ OML_OMP=.TRUE. END FUNCTION OML_OMP FUNCTION OML_IN_PARALLEL() LOGICAL :: OML_IN_PARALLEL !$ INTEGER(KIND=JPIM) :: OMP_GET_NUM_THREADS !$ LOGICAL :: OMP_IN_PARALLEL OML_IN_PARALLEL=.FALSE. !$ OML_IN_PARALLEL=((OMP_GET_NUM_THREADS() > 1).AND.OMP_IN_PARALLEL()) END FUNCTION OML_IN_PARALLEL FUNCTION OML_TEST_LOCK(MYLOCK) LOGICAL :: OML_TEST_LOCK INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ LOGICAL :: OMP_TEST_LOCK OML_TEST_LOCK = .TRUE. !$ IF (OMP_GET_MAX_THREADS() > 1) THEN !$ IF (PRESENT(MYLOCK)) THEN !$ OML_TEST_LOCK = OMP_TEST_LOCK(MYLOCK) !$ ELSE !$ OML_TEST_LOCK = OMP_TEST_LOCK(M_LOCK(1)) !$ ENDIF !$ ENDIF END FUNCTION OML_TEST_LOCK SUBROUTINE OML_UNSET_LOCK(MYLOCK) INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ IF (OMP_GET_MAX_THREADS() > 1) THEN !$ IF (PRESENT(MYLOCK)) THEN !$ CALL OMP_UNSET_LOCK(MYLOCK) !$ ELSE !$ CALL OMP_UNSET_LOCK(M_LOCK(1)) !$ ENDIF !$ ENDIF END SUBROUTINE OML_UNSET_LOCK SUBROUTINE OML_SET_LOCK(MYLOCK) INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ IF (OMP_GET_MAX_THREADS() > 1) THEN !$ IF (PRESENT(MYLOCK)) THEN !$ CALL OMP_SET_LOCK(MYLOCK) !$ ELSE !$ CALL OMP_SET_LOCK(M_LOCK(1)) !$ ENDIF !$ ENDIF END SUBROUTINE OML_SET_LOCK SUBROUTINE OML_INIT_LOCK(MYLOCK) INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ IF (OMP_GET_MAX_THREADS() > 1) THEN !$ IF (PRESENT(MYLOCK)) THEN !$ CALL OMP_INIT_LOCK(MYLOCK) !$ ELSE !$ CALL OMP_INIT_LOCK(M_LOCK(1)) !$ ENDIF !$ ENDIF END SUBROUTINE OML_INIT_LOCK SUBROUTINE OML_DESTROY_LOCK(MYLOCK) INTEGER(KIND=OML_LOCK_KIND),INTENT(INOUT),OPTIONAL :: MYLOCK !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ IF (OMP_GET_MAX_THREADS() > 1) THEN !$ IF (PRESENT(MYLOCK)) THEN !$ CALL OMP_DESTROY_LOCK(MYLOCK) !$ ELSE !$ CALL OMP_DESTROY_LOCK(M_LOCK(1)) !$ ENDIF !$ ENDIF END SUBROUTINE OML_DESTROY_LOCK FUNCTION OML_TEST_EVENT(K,MYEVENT) LOGICAL :: OML_TEST_EVENT INTEGER(KIND=JPIM),INTENT(IN) :: K,MYEVENT !$OMP FLUSH IF (K.EQ.MYEVENT) THEN OML_TEST_EVENT =.TRUE. ELSE OML_TEST_EVENT=.FALSE. ENDIF END FUNCTION OML_TEST_EVENT SUBROUTINE OML_WAIT_EVENT(K,MYEVENT) INTEGER(KIND=JPIM),INTENT(IN) :: K INTEGER(KIND=JPIM),INTENT(INOUT),OPTIONAL :: MYEVENT INTEGER(KIND=JPIM) :: ITMP IF (PRESENT(MYEVENT)) THEN DO !$OMP ATOMIC READ ITMP = MYEVENT IF ((K == ITMP)) EXIT ENDDO ELSE DO !$OMP ATOMIC READ ITMP = M_EVENT IF (K == ITMP) EXIT ENDDO ENDIF END SUBROUTINE OML_WAIT_EVENT SUBROUTINE OML_SET_EVENT(K,MYEVENT) INTEGER(KIND=JPIM),INTENT(IN) :: K INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: MYEVENT IF (PRESENT(MYEVENT)) THEN MYEVENT=K ELSE M_EVENT=K ENDIF END SUBROUTINE OML_SET_EVENT SUBROUTINE OML_INCR_EVENT(K,MYEVENT) INTEGER(KIND=JPIM) :: K INTEGER(KIND=JPIM),INTENT(INOUT),OPTIONAL :: MYEVENT !$OMP FLUSH IF (PRESENT(MYEVENT)) THEN !$OMP ATOMIC MYEVENT=MYEVENT+K ELSE !$OMP ATOMIC M_EVENT=M_EVENT+K ENDIF !$OMP FLUSH END SUBROUTINE OML_INCR_EVENT SUBROUTINE OML_INCR_COUNTER(K,KMAX) INTEGER(KIND=JPIM),INTENT(INOUT) :: K INTEGER(KIND=JPIM),INTENT(IN) :: KMAX ! Increment by 1 K=K+1 ! Security check IF (K > KMAX) THEN WRITE(NULERR,'("OML_INCR_COUNTER: ILOCK > SIZE(KLOCK), ILOCK=",I0," SIZE(KLOCK)=",I0)') K,KMAX CALL ABOR1('PLEASE INCREASE JP_LOCKS IN CALL_SL_AD') RETURN ENDIF END SUBROUTINE OML_INCR_COUNTER FUNCTION OML_MY_THREAD() INTEGER(KIND=JPIM) :: OML_MY_THREAD !$ INTEGER(KIND=JPIM) :: OMP_GET_THREAD_NUM OML_MY_THREAD = 1 !$ OML_MY_THREAD = OMP_GET_THREAD_NUM() + 1 END FUNCTION OML_MY_THREAD FUNCTION OML_MAX_THREADS() ! alias OML_GET_MAX_THREADS() INTEGER(KIND=JPIM) :: OML_MAX_THREADS !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS IF (N_OML_MAX_THREADS == -1) CALL OML_INIT() ! Harmless as usually called OUTSIDE the parallel region (checked) OML_MAX_THREADS = 1 !$ OML_MAX_THREADS = OMP_GET_MAX_THREADS() END FUNCTION OML_MAX_THREADS FUNCTION OML_GET_NUM_THREADS() INTEGER(KIND=JPIM) :: OML_GET_NUM_THREADS !$ INTEGER(KIND=JPIM) :: OMP_GET_NUM_THREADS OML_GET_NUM_THREADS = 1 !$ OML_GET_NUM_THREADS = OMP_GET_NUM_THREADS() END FUNCTION OML_GET_NUM_THREADS FUNCTION OML_SET_NUM_THREADS_INT(KOMP_SET_THREADS) INTEGER(KIND=JPIM) :: OML_SET_NUM_THREADS_INT INTEGER(KIND=JPIM),INTENT(IN) :: KOMP_SET_THREADS !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS !$ LOGICAL :: OMP_IN_PARALLEL IF (N_OML_MAX_THREADS == -1) CALL OML_INIT() ! Harmless as usually called OUTSIDE the parallel region (checked) OML_SET_NUM_THREADS_INT = 1 !$ OML_SET_NUM_THREADS_INT = OMP_GET_MAX_THREADS() !$ IF (KOMP_SET_THREADS /= OML_SET_NUM_THREADS_INT) THEN !$ IF (KOMP_SET_THREADS >= 1 .AND. KOMP_SET_THREADS <= N_OML_MAX_THREADS) THEN !- This is the absolute max no. of threads allowed --> ^^^^^^^^^^^^^^^^^ <-- !$ IF (.NOT.OMP_IN_PARALLEL()) THEN ! Change *only* if called from OUTSIDE the OpenMP-parallel region !$ CALL OMP_SET_NUM_THREADS(KOMP_SET_THREADS) ! Warning: could mess up your thread affinity !! !$ ENDIF !$ ENDIF !$ ENDIF END FUNCTION OML_SET_NUM_THREADS_INT FUNCTION OML_SET_NUM_THREADS_STR(CD_ENV) INTEGER(KIND=JPIM) :: OML_SET_NUM_THREADS_STR CHARACTER(LEN=*),INTENT(IN) :: CD_ENV !$ character(len=20) CLvalue !$ INTEGER(KIND=JPIM) :: ivalue !$ INTEGER(KIND=JPIM) :: OMP_GET_MAX_THREADS OML_SET_NUM_THREADS_STR = 1 !$ OML_SET_NUM_THREADS_STR = OMP_GET_MAX_THREADS() !$ IF (LEN(CD_ENV) > 0) THEN !$ CALL GET_ENVIRONMENT_VARIABLE(CD_ENV,CLvalue) !$ IF (CLvalue /= ' ') THEN !$ READ(CLvalue,'(i20)',end=99,err=99) ivalue !$ OML_SET_NUM_THREADS_STR = OML_SET_NUM_THREADS_INT(ivalue) !$ ENDIF !$ 99 continue !$ ENDIF END FUNCTION OML_SET_NUM_THREADS_STR !================================================================================================================================ ! C bindings ( Signatures in oml.h must match ) !================================================================================================================================ SUBROUTINE OML_SET_DEBUG_BINDC(KONOFF) BIND(C,name="oml_set_debug") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: KONOFF IF (KONOFF == 0) THEN OML_DEBUG = .FALSE. ELSE OML_DEBUG = .TRUE. ENDIF END SUBROUTINE FUNCTION OML_GET_DEBUG_BINDC() BIND(C,name="oml_get_debug") RESULT(KRET) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KRET KRET = 0 IF (OML_DEBUG) KRET = 1 END FUNCTION SUBROUTINE OML_INIT_LOCKID_WITH_NAME_BINDC(KMYLOCK,CDLOCKNAME) BIND(C,NAME="oml_init_lockid_with_name") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T, C_CHAR IMPLICIT NONE INTEGER(KIND=OML_LOCK_KIND), INTENT(INOUT) :: KMYLOCK CHARACTER(KIND=C_CHAR,LEN=1), INTENT(IN) :: CDLOCKNAME(*) INTEGER(KIND=C_INTPTR_T), EXTERNAL :: LOC_ADDR CALL OML_INIT_LOCK(KMYLOCK) IF (OML_DEBUG) WRITE(0,'(1x,a,2i20)') & & 'oml_init_lockid_with_name "'//from_c_str(CDLOCKNAME)//'" :',KMYLOCK,LOC_ADDR(KMYLOCK) CONTAINS function from_c_str(s) result(string) use, intrinsic :: iso_c_binding, only : c_char, c_null_char character(kind=c_char,len=1), intent(in) :: s(*) character(len=:), allocatable :: string integer i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 enddo nchars = i - 1 ! Exclude null character from Fortran string allocate( character(len=(nchars)) :: string ) do i=1,nchars string(i:i) = s(i) enddo end function END SUBROUTINE SUBROUTINE OML_INIT_LOCKID_BINDC(KMYLOCK) BIND(C,NAME="oml_init_lockid") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T IMPLICIT NONE INTEGER(KIND=OML_LOCK_KIND), INTENT(INOUT) :: KMYLOCK INTEGER(KIND=C_INTPTR_T), EXTERNAL :: LOC_ADDR CALL OML_INIT_LOCK(KMYLOCK) IF (OML_DEBUG) WRITE(0,'(1x,2i20)') & & 'oml_init_lockid :',KMYLOCK,LOC_ADDR(KMYLOCK) END SUBROUTINE SUBROUTINE OML_INIT_LOCK_BINDC() BIND(C,NAME="oml_init_lock") IMPLICIT NONE CALL OML_INIT_LOCK() END SUBROUTINE SUBROUTINE OML_DESTROY_LOCK_BINDC() BIND(C,NAME="oml_destroy_lock") IMPLICIT NONE CALL OML_DESTROY_LOCK() END SUBROUTINE FUNCTION OML_TEST_LOCKID_BINDC(KMYLOCK) BIND(C,NAME="oml_test_lockid") RESULT(KISSET) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KISSET INTEGER(KIND=OML_LOCK_KIND), INTENT(INOUT) :: KMYLOCK KISSET = 1 IF (.NOT.OML_TEST_LOCK(KMYLOCK)) KISSET = 0 END FUNCTION FUNCTION OML_TEST_LOCK_BINDC() BIND(C,NAME="oml_test_lock") RESULT(KISSET) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KISSET KISSET = 1 IF (.NOT.OML_TEST_LOCK()) KISSET = 0 END FUNCTION SUBROUTINE OML_SET_LOCKID_BINDC(KMYLOCK) BIND(C,NAME="oml_set_lockid") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T USE EC_PARKIND, ONLY : JPRD IMPLICIT NONE INTEGER(KIND=OML_LOCK_KIND), INTENT(INOUT) :: KMYLOCK INTEGER(KIND=C_INTPTR_T), EXTERNAL :: LOC_ADDR REAL(KIND=JPRD), EXTERNAL :: UTIL_WALLTIME IF (OML_DEBUG) WRITE(0,'(1x,f20.6,1x,i3,a,2i20)') & & UTIL_WALLTIME(),OML_MY_THREAD(),': oml_set_lockid >>',KMYLOCK,LOC_ADDR(KMYLOCK) CALL OML_SET_LOCK(KMYLOCK) IF (OML_DEBUG) WRITE(0,'(1x,f20.6,1x,i3,a,2i20)') & & UTIL_WALLTIME(),OML_MY_THREAD(),': oml_set_lockid <<',KMYLOCK,LOC_ADDR(KMYLOCK) END SUBROUTINE SUBROUTINE OML_SET_LOCK_BINDC() BIND(C,NAME="oml_set_lock") IMPLICIT NONE CALL OML_SET_LOCK() END SUBROUTINE SUBROUTINE OML_UNSET_LOCK_BINDC() BIND(C,NAME="oml_unset_lock") IMPLICIT NONE CALL OML_UNSET_LOCK() END SUBROUTINE SUBROUTINE OML_UNSET_LOCKID_BINDC(KMYLOCK) BIND(C,NAME="oml_unset_lockid") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T USE EC_PARKIND, ONLY : JPRD IMPLICIT NONE INTEGER(KIND=OML_LOCK_KIND), INTENT(INOUT) :: KMYLOCK INTEGER(KIND=C_INTPTR_T), EXTERNAL :: LOC_ADDR REAL(KIND=JPRD), EXTERNAL :: UTIL_WALLTIME IF (OML_DEBUG) WRITE(0,'(1x,f20.6,1x,i3,a,2i20)') & & UTIL_WALLTIME(),OML_MY_THREAD(),': oml_unset_lockid >>',KMYLOCK,LOC_ADDR(KMYLOCK) CALL OML_UNSET_LOCK(KMYLOCK) IF (OML_DEBUG) WRITE(0,'(1x,f20.6,1x,i3,a,2i20)') & & UTIL_WALLTIME(),OML_MY_THREAD(),': oml_unset_lockid <<',KMYLOCK,LOC_ADDR(KMYLOCK) END SUBROUTINE FUNCTION OML_IN_PARALLEL_BINDC() BIND(C,NAME="oml_in_parallel") RESULT(KISPAR_REGION) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KISPAR_REGION KISPAR_REGION = 0 IF (OML_IN_PARALLEL()) KISPAR_REGION = 1 END FUNCTION FUNCTION OML_GET_MAX_THREADS_BINDC() BIND(C,NAME="oml_get_max_threads") RESULT(KTIDS) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KTIDS KTIDS = OML_GET_MAX_THREADS() END FUNCTION FUNCTION OML_GET_NUM_THREADS_BINDC() BIND(C,NAME="oml_get_num_threads") RESULT(KTIDS) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KTIDS KTIDS = OML_GET_NUM_THREADS() END FUNCTION FUNCTION OML_GET_THREAD_NUM_BINDC() BIND(C,NAME="oml_get_thread_num") RESULT(KMYTID) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KMYTID KMYTID = OML_MY_THREAD() - 1 END FUNCTION FUNCTION OML_MY_THREAD_BINDC() BIND(C,NAME="oml_my_thread") RESULT(KMYTID) USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT) :: KMYTID KMYTID = OML_MY_THREAD() END FUNCTION SUBROUTINE OMP_RUN_PARALLEL_BINDC(FUNC, ARGS) BIND(C,NAME="oml_run_parallel") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_FUNPTR, C_PTR, C_F_PROCPOINTER TYPE(C_FUNPTR), VALUE :: FUNC TYPE(C_PTR), VALUE :: ARGS PROCEDURE(OML_PARALLEL_FUNCTION), POINTER :: PROC ! Convert C to Fortran procedure pointer CALL C_F_PROCPOINTER(FUNC, PROC) !$OMP PARALLEL CALL PROC(ARGS) !$OMP END PARALLEL END SUBROUTINE SUBROUTINE OML_BARRIER_BINDC() BIND(C,NAME="oml_barrier") !$OMP BARRIER END SUBROUTINE END MODULE OML_MOD fiat-ecmwf-2.0.0/src/fiat/drhook/0000775000175000017500000000000015157200431016715 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/drhook/internal/0000775000175000017500000000000015157200431020531 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_util.h0000664000175000017500000000140015157200431023357 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE DR_HOOK_UTIL(LDHOOK,CDNAME,KCASE,PKEY,CDFILENAME,KSIZEINFO) USE EC_PARKIND ,ONLY : JPIM ,JPRD IMPLICIT NONE LOGICAL, INTENT(INOUT) :: LDHOOK CHARACTER(LEN=*),INTENT(IN) :: CDNAME,CDFILENAME INTEGER(KIND=JPIM),INTENT(IN) :: KCASE,KSIZEINFO REAL(KIND=JPRD),INTENT(INOUT) :: PKEY END SUBROUTINE DR_HOOK_UTIL END INTERFACE fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_stackcheck_mod.F900000664000175000017500000000137415157200431025465 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE DR_HOOK_STACKCHECK_MOD ! Used by dr_hook_util to monitor thread stack usage USE EC_PARKIND ,ONLY : JPIB IMPLICIT NONE SAVE PRIVATE :: JPIB PUBLIC INTEGER(KIND=JPIB), ALLOCATABLE :: ISAVE(:) INTEGER(KIND=JPIB), ALLOCATABLE :: IMAXSTACK(:) LOGICAL, ALLOCATABLE :: LL_THREAD_FIRST(:) END MODULE DR_HOOK_STACKCHECK_MOD fiat-ecmwf-2.0.0/src/fiat/drhook/internal/cas.h0000664000175000017500000000274015157200431021453 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ // cas.h // // compare_and_swap -based locks // // Thanks to https://github.com/majek/dump/blob/master/msqueue/queue_lock_myspinlock1.c // #include #include #ifndef INLINE #define INLINE __inline__ #endif #if defined(__PGIC__) && defined(__PGIC_MINOR__) #if __PGIC__ <= 20 && __PGIC_MINOR__ < 7 #define PGI_NO_SUPPORT #endif #endif #if defined(__GNUC__) && !defined(__NEC__) && !defined(PGI_NO_SUPPORT) #define CAS(lock,oldval,newval) __sync_bool_compare_and_swap(lock,oldval,newval) #else #warning *** CAS-locks self-implemented *** static INLINE int CAS(volatile sig_atomic_t *lock, int oldval, int newval) { int tmp = *lock; if (tmp == oldval) *lock = newval; return tmp; } #endif static INLINE void cas_init(volatile sig_atomic_t *lock) { if (lock) *lock = 0; } static INLINE void cas_lock(volatile sig_atomic_t *lock) { while (1) { int i; for (i=0; i < 10000; ++i) { if (CAS(lock, 0, 1)) return; } sched_yield(); } } static INLINE void cas_unlock(volatile sig_atomic_t *lock) { CAS(lock, 1, 0); } fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_prt.F900000664000175000017500000000526515157200431023333 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE DR_HOOK_PRT(KUNIT, CDSTR) USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT CHARACTER(LEN=*), INTENT(IN) :: CDSTR IF (KUNIT < 0) THEN WRITE(*,'(A)') CDSTR ELSE WRITE(KUNIT,'(A)') CDSTR CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT SUBROUTINE DR_HOOK_PRT_CHAR(KUNIT, CD, KLD) USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT INTEGER(KIND=JPIM), INTENT(IN) :: KLD CHARACTER(LEN=1), INTENT(IN) :: CD(KLD) IF (KUNIT < 0) THEN WRITE(*,'(40A1)') CD ELSE WRITE(*,'(40A1)') CD CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT_CHAR SUBROUTINE DR_HOOK_PRT_LOGICAL(KUNIT, LD, KLD) USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT INTEGER(KIND=JPIM), INTENT(IN) :: KLD LOGICAL, INTENT(IN) :: LD(KLD) IF (KUNIT < 0) THEN WRITE(*,'(40L2)') LD ELSE WRITE(KUNIT,'(40L2)') LD CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT_LOGICAL SUBROUTINE DR_HOOK_PRT_I4(KUNIT, KD, KLD) USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT INTEGER(KIND=JPIM), INTENT(IN) :: KLD INTEGER(KIND=JPIM), INTENT(IN) :: KD(KLD) IF (KUNIT < 0) THEN WRITE(*,'(5I12)') KD ELSE WRITE(KUNIT,'(5I12)') KD CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT_I4 SUBROUTINE DR_HOOK_PRT_I8(KUNIT, KD, KLD) USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT INTEGER(KIND=JPIM), INTENT(IN) :: KLD INTEGER(KIND=JPIB), INTENT(IN) :: KD(KLD) IF (KUNIT < 0) THEN WRITE(*,'(5I20)') KD ELSE WRITE(KUNIT,'(5I20)') KD CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT_I8 SUBROUTINE DR_HOOK_PRT_R4(KUNIT, PD, KLD) USE EC_PARKIND ,ONLY : JPIM, JPIB, JPRM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT INTEGER(KIND=JPIM), INTENT(IN) :: KLD REAL(KIND=JPRM), INTENT(IN) :: PD(KLD) IF (KUNIT < 0) THEN WRITE(*,*) PD ELSE WRITE(KUNIT,*) PD CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT_R4 SUBROUTINE DR_HOOK_PRT_R8(KUNIT, PD, KLD) USE EC_PARKIND ,ONLY : JPIM, JPIB, JPRD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUNIT INTEGER(KIND=JPIM), INTENT(IN) :: KLD REAL(KIND=JPRD), INTENT(IN) :: PD(KLD) IF (KUNIT < 0) THEN WRITE(*,*) PD ELSE WRITE(KUNIT,*) PD CALL EC_FLUSH(KUNIT) ENDIF END SUBROUTINE DR_HOOK_PRT_R8 fiat-ecmwf-2.0.0/src/fiat/drhook/internal/drhook_run_omp_parallel.F900000664000175000017500000000737715157200431025730 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! These functions are to be used within drhook C methods, to avoid having OMP pragmas there. module drhook_papi_interface #if defined(DR_HOOK_HAVE_PAPI) interface function drhook_papi_start_threads ( events) bind ( c ) use, intrinsic :: iso_c_binding, only : c_int integer(kind=c_int) :: drhook_papi_start_threads integer(kind=c_int), intent(inout) :: events(*) end function drhook_papi_start_threads end interface #endif end module drhook_papi_interface subroutine drhook_run_omp_parallel_ipfstr(NTIDS, FUNC, CDSTR) ! Usage: ! ------ ! void func( const char* string, long strlength ) { ... } ! extern void drhook_run_omp_parallel_ipfstr_(const int *, void (*func)(const char *, long), ! const char *, /*hidden*/ long); ! drhook_run_omp_parallel_ipfstr_(&ntids,func,string,strlen(string)); use, intrinsic :: iso_c_binding, only : c_char, c_int implicit none INTEGER(KIND=C_INT), INTENT(IN) :: NTIDS EXTERNAL :: FUNC CHARACTER(LEN=*,KIND=C_CHAR), INTENT(IN) :: CDSTR !$OMP PARALLEL NUM_THREADS(NTIDS) CALL FUNC(CDSTR) !$OMP END PARALLEL end subroutine drhook_run_omp_parallel_ipfstr subroutine drhook_run_omp_parallel_ipfipipipdpstr(NTIDS, FUNC, KTIDS, TARGET_OMPTID, TARGET_SIG, START_TIME, CDSTR) use, intrinsic :: iso_c_binding, only : c_char, c_int, c_double implicit none INTEGER(KIND=C_INT), INTENT(IN) :: NTIDS, KTIDS, TARGET_OMPTID, TARGET_SIG REAL(KIND=C_DOUBLE), INTENT(IN) :: START_TIME CHARACTER(LEN=*,KIND=C_CHAR), INTENT(IN) :: CDSTR EXTERNAL :: FUNC !$OMP PARALLEL NUM_THREADS(NTIDS) CALL FUNC(KTIDS, TARGET_OMPTID, TARGET_SIG, START_TIME, CDSTR) !$OMP END PARALLEL end subroutine drhook_run_omp_parallel_ipfipipipdpstr subroutine drhook_run_omp_parallel_get_cycles(NTIDS, NCYCLES) use, intrinsic :: iso_c_binding, only : c_int, c_long_long use ec_parkind, only : JPIM, JPIB implicit none INTEGER(KIND=C_INT), INTENT(IN) :: NTIDS INTEGER(KIND=C_LONG_LONG), INTENT(INOUT) :: NCYCLES(0:NTIDS-1) INTEGER(KIND=JPIM) :: IOMPTID INTEGER(KIND=JPIM) OMP_GET_THREAD_NUM INTEGER(KIND=C_LONG_LONG), EXTERNAL :: ec_get_cycles ! from ec_get_cycles.c INTEGER(KIND=C_LONG_LONG) :: ICYCLES #ifdef _OPENMP EXTERNAL OMP_GET_THREAD_NUM #else OMP_GET_THREAD_NUM() = 0 #endif !-- Obtain per OpenMP-thread CPU-cycles increment since last call !$OMP PARALLEL NUM_THREADS(NTIDS) PRIVATE(IOMPTID,ICYCLES) SHARED(NCYCLES) IOMPTID = OMP_GET_THREAD_NUM() ICYCLES = ec_get_cycles() NCYCLES(IOMPTID) = ICYCLES - NCYCLES(IOMPTID) !$OMP END PARALLEL end subroutine drhook_run_omp_parallel_get_cycles #if defined(DR_HOOK_HAVE_PAPI) subroutine drhook_run_omp_parallel_papi_startup(events, n, rcOut) bind(c) use, intrinsic :: iso_c_binding, only : c_char, c_int, c_double use drhook_papi_interface use OML_MOD implicit none INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: n INTEGER(KIND=C_INT), INTENT(INOUT) :: Events(n) INTEGER(KIND=C_INT) :: thread INTEGER(KIND=C_INT) :: rc INTEGER(KIND=C_INT), INTENT(OUT) :: rcOut INTEGER :: myThread INTEGER :: nThreads nThreads=OML_GET_MAX_THREADS() rcOut=0 !$OMP PARALLEL PRIVATE(myThread,rc) SHARED(rcOut) myThread=OML_MY_THREAD()-1 DO thread=0,nThreads-1 if (thread==myThread) then rc=drhook_papi_start_threads(events) if (rc==0) rcOut=1 end if !$OMP BARRIER END DO !$OMP END PARALLEL end subroutine drhook_run_omp_parallel_papi_startup #endif fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_util_multi.F900000664000175000017500000000370415157200431024711 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE DR_HOOK_UTIL_MULTI(LDHOOK,CDNAME,KCASE,PKEY,KPKEY,CDFILENAME,KSIZEINFO) USE EC_PARKIND ,ONLY : JPIM ,JPRD USE OML_MOD,ONLY : OML_GET_MAX_THREADS,OML_MY_THREAD IMPLICIT NONE LOGICAL,INTENT(INOUT) :: LDHOOK CHARACTER(LEN=*),INTENT(IN) :: CDNAME,CDFILENAME INTEGER(KIND=JPIM),INTENT(IN) :: KPKEY, KCASE,KSIZEINFO REAL(KIND=JPRD),INTENT(INOUT) :: PKEY(KPKEY) LOGICAL,SAVE :: LL_FIRST_TIME = .TRUE. REAL(KIND=JPRD) :: ZDUMMY INTEGER(KIND=JPIM) :: IMYTID, ISILENT, IMAXTH #include "dr_hook_util.h" ! ----------------------------------------------------------------- IF (.NOT.LDHOOK) RETURN IF (LL_FIRST_TIME) THEN LL_FIRST_TIME = .FALSE. CALL DR_HOOK_UTIL(LDHOOK,'',-1,ZDUMMY,'',-1_JPIM) ! Approximately the very first OpenMP-loop IMAXTH = OML_GET_MAX_THREADS() ! trapfpe setting also for slave threads -- was missing !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(IMYTID,ISILENT) IF (IMAXTH > 1) DO IMYTID=1,IMAXTH ISILENT = 1 ! no verbosity IF (IMYTID == IMAXTH) ISILENT = 0 ! be verbose with the last thread CALL TRAPFPE_SLAVE_THREADS(ISILENT) ! see drhook.c; does not do anything on master thread ENDDO ! IMYTID=1,IMAXTH !$OMP END PARALLEL DO ENDIF !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(IMYTID) DO IMYTID=1,KPKEY IF (KCASE == 0) THEN CALL C_DRHOOK_START(CDNAME, IMYTID, PKEY(IMYTID), CDFILENAME, KSIZEINFO) ELSE IF (KCASE == 1) THEN CALL C_DRHOOK_END (CDNAME, IMYTID, PKEY(IMYTID), CDFILENAME, KSIZEINFO) ENDIF ENDDO ! IMYTID=1,KPKEY !$OMP END PARALLEL DO END SUBROUTINE DR_HOOK_UTIL_MULTI fiat-ecmwf-2.0.0/src/fiat/drhook/internal/crc.c0000664000175000017500000001406015157200431021445 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* crc.c : in fact equivalent to Unix cksum (when crc32) */ /* Calculates 32-bit Cyclic Redundancy Check as in Unix cksum command */ /* Also calculates 64-bit Cyclic Redundancy Check */ /* Sami Saarinen, 17-Feb-2005 : crc32 */ /* 24-Jun-2005 : Added crc64 */ /* 29-Dec-2005 : Removed static in front of C-callable cksum32() */ /* 29-Dec-2005 : Length argument for crc64 now 64-bit int */ #include #include #include #include "crc.h" static const unsigned int crctab[256] = { 0x0, 0x04C11DB7, 0x09823B6E, 0x0D4326D9, 0x130476DC, 0x17C56B6B, 0x1A864DB2, 0x1E475005, 0x2608EDB8, 0x22C9F00F, 0x2F8AD6D6, 0x2B4BCB61, 0x350C9B64, 0x31CD86D3, 0x3C8EA00A, 0x384FBDBD, 0x4C11DB70, 0x48D0C6C7, 0x4593E01E, 0x4152FDA9, 0x5F15ADAC, 0x5BD4B01B, 0x569796C2, 0x52568B75, 0x6A1936C8, 0x6ED82B7F, 0x639B0DA6, 0x675A1011, 0x791D4014, 0x7DDC5DA3, 0x709F7B7A, 0x745E66CD, 0x9823B6E0, 0x9CE2AB57, 0x91A18D8E, 0x95609039, 0x8B27C03C, 0x8FE6DD8B, 0x82A5FB52, 0x8664E6E5, 0xBE2B5B58, 0xBAEA46EF, 0xB7A96036, 0xB3687D81, 0xAD2F2D84, 0xA9EE3033, 0xA4AD16EA, 0xA06C0B5D, 0xD4326D90, 0xD0F37027, 0xDDB056FE, 0xD9714B49, 0xC7361B4C, 0xC3F706FB, 0xCEB42022, 0xCA753D95, 0xF23A8028, 0xF6FB9D9F, 0xFBB8BB46, 0xFF79A6F1, 0xE13EF6F4, 0xE5FFEB43, 0xE8BCCD9A, 0xEC7DD02D, 0x34867077, 0x30476DC0, 0x3D044B19, 0x39C556AE, 0x278206AB, 0x23431B1C, 0x2E003DC5, 0x2AC12072, 0x128E9DCF, 0x164F8078, 0x1B0CA6A1, 0x1FCDBB16, 0x018AEB13, 0x054BF6A4, 0x0808D07D, 0x0CC9CDCA, 0x7897AB07, 0x7C56B6B0, 0x71159069, 0x75D48DDE, 0x6B93DDDB, 0x6F52C06C, 0x6211E6B5, 0x66D0FB02, 0x5E9F46BF, 0x5A5E5B08, 0x571D7DD1, 0x53DC6066, 0x4D9B3063, 0x495A2DD4, 0x44190B0D, 0x40D816BA, 0xACA5C697, 0xA864DB20, 0xA527FDF9, 0xA1E6E04E, 0xBFA1B04B, 0xBB60ADFC, 0xB6238B25, 0xB2E29692, 0x8AAD2B2F, 0x8E6C3698, 0x832F1041, 0x87EE0DF6, 0x99A95DF3, 0x9D684044, 0x902B669D, 0x94EA7B2A, 0xE0B41DE7, 0xE4750050, 0xE9362689, 0xEDF73B3E, 0xF3B06B3B, 0xF771768C, 0xFA325055, 0xFEF34DE2, 0xC6BCF05F, 0xC27DEDE8, 0xCF3ECB31, 0xCBFFD686, 0xD5B88683, 0xD1799B34, 0xDC3ABDED, 0xD8FBA05A, 0x690CE0EE, 0x6DCDFD59, 0x608EDB80, 0x644FC637, 0x7A089632, 0x7EC98B85, 0x738AAD5C, 0x774BB0EB, 0x4F040D56, 0x4BC510E1, 0x46863638, 0x42472B8F, 0x5C007B8A, 0x58C1663D, 0x558240E4, 0x51435D53, 0x251D3B9E, 0x21DC2629, 0x2C9F00F0, 0x285E1D47, 0x36194D42, 0x32D850F5, 0x3F9B762C, 0x3B5A6B9B, 0x0315D626, 0x07D4CB91, 0x0A97ED48, 0x0E56F0FF, 0x1011A0FA, 0x14D0BD4D, 0x19939B94, 0x1D528623, 0xF12F560E, 0xF5EE4BB9, 0xF8AD6D60, 0xFC6C70D7, 0xE22B20D2, 0xE6EA3D65, 0xEBA91BBC, 0xEF68060B, 0xD727BBB6, 0xD3E6A601, 0xDEA580D8, 0xDA649D6F, 0xC423CD6A, 0xC0E2D0DD, 0xCDA1F604, 0xC960EBB3, 0xBD3E8D7E, 0xB9FF90C9, 0xB4BCB610, 0xB07DABA7, 0xAE3AFBA2, 0xAAFBE615, 0xA7B8C0CC, 0xA379DD7B, 0x9B3660C6, 0x9FF77D71, 0x92B45BA8, 0x9675461F, 0x8832161A, 0x8CF30BAD, 0x81B02D74, 0x857130C3, 0x5D8A9099, 0x594B8D2E, 0x5408ABF7, 0x50C9B640, 0x4E8EE645, 0x4A4FFBF2, 0x470CDD2B, 0x43CDC09C, 0x7B827D21, 0x7F436096, 0x7200464F, 0x76C15BF8, 0x68860BFD, 0x6C47164A, 0x61043093, 0x65C52D24, 0x119B4BE9, 0x155A565E, 0x18197087, 0x1CD86D30, 0x029F3D35, 0x065E2082, 0x0B1D065B, 0x0FDC1BEC, 0x3793A651, 0x3352BBE6, 0x3E119D3F, 0x3AD08088, 0x2497D08D, 0x2056CD3A, 0x2D15EBE3, 0x29D4F654, 0xC5A92679, 0xC1683BCE, 0xCC2B1D17, 0xC8EA00A0, 0xD6AD50A5, 0xD26C4D12, 0xDF2F6BCB, 0xDBEE767C, 0xE3A1CBC1, 0xE760D676, 0xEA23F0AF, 0xEEE2ED18, 0xF0A5BD1D, 0xF464A0AA, 0xF9278673, 0xFDE69BC4, 0x89B8FD09, 0x8D79E0BE, 0x803AC667, 0x84FBDBD0, 0x9ABC8BD5, 0x9E7D9662, 0x933EB0BB, 0x97FFAD0C, 0xAFB010B1, 0xAB710D06, 0xA6322BDF, 0xA2F33668, 0xBCB4666D, 0xB8757BDA, 0xB5365D03, 0xB1F740B4 }; unsigned int cksum32(const char *buf, int nbuf, unsigned int nCRC) { while (nbuf--) { nCRC = (nCRC << 8) ^ crctab[((nCRC >> 24) ^ *(buf++)) & 0xFF]; } return nCRC; } unsigned long long int cksum64(const char *buf, long long int nbuf, unsigned long long int nCRC) { unsigned char c; while (nbuf--) { c = ((unsigned char)nCRC ^ *(buf++)) & 0xFF; nCRC >>= 8; nCRC ^= (unsigned long long int)crctab[c] << 32; } return nCRC; } unsigned int pp_cksum32(int nbuf, unsigned int nCRC) { while (nbuf > 0) { nCRC = (nCRC << 8) ^ crctab[((nCRC >> 24) ^ nbuf) & 0xFF]; nbuf >>= 8; } nCRC = ~nCRC & 0xFFFFFFFF; return nCRC; } unsigned int pp_cksum32but64len(long long int nbuf, unsigned int nCRC) { while (nbuf > 0) { nCRC = (nCRC << 8) ^ crctab[((nCRC >> 24) ^ nbuf) & 0xFF]; nbuf >>= 8; } nCRC = ~nCRC & 0xFFFFFFFF; return nCRC; } unsigned long long int pp_cksum64(long long int nbuf, unsigned long long int nCRC) { while (nbuf > 0) { unsigned char c = ((unsigned char)nCRC ^ nbuf) & 0xFF; nCRC >>= 8; nCRC ^= (unsigned long long int)crctab[c] << 32; nbuf >>= 8; } nCRC = ~nCRC & 0xFFFFFFFFFFFFFFFFull; return nCRC; } /* Fortran callable */ void crc32_(const void *vbuf, const int *pnbuf, unsigned int *pnCRC /* Note: An in & out -variable */) { if (vbuf && pnbuf && *pnbuf > 0 && pnCRC) { const char *buf = vbuf; unsigned int nCRC = *pnCRC; int nbuf = *pnbuf; /* checksum the data */ nCRC = cksum32(buf, nbuf, nCRC); /* checksum the length */ *pnCRC = pp_cksum32(nbuf, nCRC); } } void crc64_(const void *vbuf, const long long int *pnbuf, unsigned long long int *pnCRC /* Note: An in & out -variable */) { if (vbuf && pnbuf && *pnbuf > 0 && pnCRC) { const char *buf = vbuf; unsigned long long int nCRC = *pnCRC; long long int nbuf = *pnbuf; /* checksum the data */ nCRC = cksum64(buf, nbuf, nCRC); /* checksum the length */ *pnCRC = pp_cksum64(nbuf, nCRC); } } fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hack_mod.F900000664000175000017500000001101415157200431023240 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE DR_HACK_MOD USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE PRIVATE LOGICAL, SAVE, PUBLIC :: LL_DRHACK = .FALSE. ! Will be set to .TRUE. if envvar DR_HACK=1 INTEGER(KIND=JPIM), PUBLIC :: NULDRHACK = 999 ! Output unit for drHack pseudo xml file PUBLIC :: DR_HACK_INIT PUBLIC :: DR_HACK PUBLIC :: DR_HACK_END CONTAINS SUBROUTINE DR_HACK_INIT() IMPLICIT NONE CHARACTER(LEN=512) :: CLENV CALL GET_ENVIRONMENT_VARIABLE('DR_HACK',CLENV) IF( CLENV == 'yes' .OR. CLENV == 'YES' .OR. & & CLENV == 'true' .OR. CLENV == 'TRUE' .OR. & & CLENV == 'on' .OR. CLENV == 'ON' .OR. & & CLENV == '1' ) THEN LL_DRHACK=.TRUE. IF( MYPROC() == 1 ) THEN OPEN (UNIT = NULDRHACK, file = "drhack.txt",position="append",action="write") ENDIF ENDIF CONTAINS FUNCTION MYPROC() USE MPL_DATA_MODULE ,ONLY : MPL_NUMPROC USE MPL_MYRANK_MOD ,ONLY : MPL_MYRANK INTEGER(KIND=JPIM) :: MYPROC IF( MPL_NUMPROC > 0 ) THEN MYPROC = MPL_MYRANK() ELSE MYPROC = 1 ENDIF END FUNCTION MYPROC END SUBROUTINE DR_HACK_INIT SUBROUTINE DR_HACK_END() IMPLICIT NONE LOGICAL LOPENED INQUIRE(UNIT=NULDRHACK, OPENED=LOPENED) IF( LOPENED ) THEN CLOSE (NULDRHACK) ENDIF END SUBROUTINE DR_HACK_END SUBROUTINE DR_HACK(ROUTINE,START) ! ! Florian Suzat (METEO-FRANCE) Sept 2017 : add drHack functionality ! ! drHack documentation: ! ---------------------------------- ! ARPIFS has become a huge and complicated program. Debugging it can be very ! painful especially for newbies. Documenting it is also is a huge and tedious ! job. ! The idea behind “drHack” is basically to hack drHook: using the calls ! "IF (LHOOK) CALL DR_HOOK('XXX',I,ZHOOK_HANDLE)" ! (where XXX is the name of a routine, and I is 0 at the beginning of the ! routine and 1 at ! the end) in order to build a big XML file describing the ARPIFS calling tree. ! At initialization, if both environmental variables DR_HOOK and DR_HACK are set ! equal to 1, ! then the hack is activated, otherwise everything works as usual. ! IMPORTANT: for the moment, it does not work with openmp ! (need to run with openmp=1) ! When active, we first open a file drhack.txt. ! Every time the program enters a routine, we append to the ! file, and every time the routine is left, we append (mind the ! “/” extra character). ! Then, at the end of the run, the (big!) file drhack.txt contains the calling ! tree of the MPI processor number 0 as an XML file: ! ! ! ! ! ! ! ! ! .... ! ! The resulting files are not usable as is (because they are too big). But with ! a few ! lines of python, it is easy to produce a condensed version of the drhack.txt ! file ! (if you want an example script, you may ask florian.suzat@meteo.fr). ! Then, with html and javascript, these condensed files are read and a ! dynamic collapsible search tree is built. ! Illustrations of such pages can be seen at http://intra.cnrm.meteo.fr/drhack/ ! (only from the MeteoFrance network... If you want an export, mail ! florian.suzat@meteo.fr) ! Hope this help... ! ----------------------------------------------------------------- ! Different implementation of this have been tested, but this one, even if it is ! not elegant at all, is almost fast.... IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: ROUTINE INTEGER(KIND=JPIM),INTENT(IN) :: START INTEGER(KIND=JPIM) :: i CHARACTER(LEN(ROUTINE)) :: ROUTINE_CLEAN ! replace some special character DO i = 1,LEN(ROUTINE) SELECT CASE (ROUTINE(i:i)) CASE ("<") ROUTINE_CLEAN (i:i)="_" CASE (">") ROUTINE_CLEAN (i:i)="_" CASE (":") ROUTINE_CLEAN (i:i)="_" CASE (" ") ROUTINE_CLEAN (i:i)="_" CASE DEFAULT ROUTINE_CLEAN (i:i)=ROUTINE(i:i) END SELECT END DO IF (START==0) THEN WRITE(NULDRHACK,*) '<',ROUTINE_CLEAN,'>' ELSE WRITE(NULDRHACK,*) '' !CLOSE FILE IF LAST ROUTINE IF (ROUTINE_CLEAN .eq. 'MODEL_MOD_MODEL_DELETE') THEN CLOSE(NULDRHACK) ENDIF ENDIF END SUBROUTINE DR_HACK END MODULE fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_procinfo.F900000664000175000017500000000251315157200431024336 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE DR_HOOK_PROCINFO(KMYPROC, KNPROC, LMPI_INITIALIZED) USE EC_PARKIND ,ONLY : JPIM USE MPL_MPI IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(OUT) :: KMYPROC, KNPROC LOGICAL, INTENT(OUT) :: LMPI_INITIALIZED INTEGER(KIND=JPIM) :: IERROR KMYPROC=1 KNPROC=1 CALL MPI_INITIALIZED(LMPI_INITIALIZED,IERROR) IF( LMPI_INITIALIZED ) THEN CALL MPI_COMM_SIZE(MPI_COMM_WORLD,KNPROC,IERROR) CALL MPI_COMM_RANK(MPI_COMM_WORLD,KMYPROC,IERROR) KMYPROC = KMYPROC+1 ! 1-based in IFS context ENDIF END SUBROUTINE DR_HOOK_PROCINFO SUBROUTINE C_DR_HOOK_PROCINFO(KMYPROC, KNPROC, KMPI_INITIALIZED) BIND(C, name="c_dr_hook_procinfo") USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT IMPLICIT NONE INTEGER(KIND=C_INT), INTENT(OUT) :: KMYPROC, KNPROC, KMPI_INITIALIZED LOGICAL :: LLMPI_INITIALIZED CALL DR_HOOK_PROCINFO(KMYPROC, KNPROC, LLMPI_INITIALIZED) KMPI_INITIALIZED = MERGE(1, 0, LLMPI_INITIALIZED) END SUBROUTINE C_DR_HOOK_PROCINFO fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_util_multi.h0000664000175000017500000000144415157200431024601 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE DR_HOOK_UTIL_MULTI(LDHOOK,CDNAME,KCASE,PKEY,KPKEY,CDFILENAME,KSIZEINFO) USE EC_PARKIND ,ONLY : JPIM ,JPRD IMPLICIT NONE LOGICAL,INTENT(INOUT) :: LDHOOK CHARACTER(LEN=*),INTENT(IN) :: CDNAME,CDFILENAME INTEGER(KIND=JPIM),INTENT(IN) :: KPKEY, KCASE,KSIZEINFO REAL(KIND=JPRD),INTENT(INOUT) :: PKEY(KPKEY) END SUBROUTINE DR_HOOK_UTIL_MULTI END INTERFACE fiat-ecmwf-2.0.0/src/fiat/drhook/internal/cdrhookinit.F900000664000175000017500000000141715157200431023331 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE CDRHOOKINIT(KRET) !-- Makes sure Dr.Hook gets properly initialized from C-main program, too USE EC_PARKIND ,ONLY : JPIM, JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK_INIT IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(OUT) :: KRET CALL DR_HOOK_INIT() IF (LHOOK) THEN KRET = 1 ! Dr.Hook is ON ELSE KRET = 0 ! Dr.Hook is OFF ENDIF END SUBROUTINE CDRHOOKINIT fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_util.F900000664000175000017500000001566415157200431023507 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE DR_HOOK_UTIL(LDHOOK,CDNAME,KCASE,PKEY,CDFILENAME,KSIZEINFO) USE EC_PARKIND , ONLY : JPIM, JPRD USE OML_MOD , ONLY : OML_MY_THREAD USE YOMHOOK , ONLY : LHOOK USE DR_HACK_MOD, ONLY : LL_DRHACK, DR_HACK_INIT, DR_HACK IMPLICIT NONE ! Arguments LOGICAL,INTENT(INOUT) :: LDHOOK CHARACTER(LEN=*),INTENT(IN) :: CDNAME,CDFILENAME INTEGER(KIND=JPIM),INTENT(IN) :: KCASE,KSIZEINFO REAL(KIND=JPRD),INTENT(INOUT) :: PKEY ! Persistent variables, setup at first call LOGICAL,SAVE :: LL_INIT = .FALSE. LOGICAL,SAVE :: LL_STACKCHECK = .FALSE. ! Will be set to .TRUE. if envvar DR_HOOK_STACKCHECK=1 LOGICAL,SAVE :: LL_HEAPCHECK = .FALSE. ! Will be set to .TRUE. if envvar DR_HOOK_HEAPCHECK=1 ! Local variables INTEGER(KIND=JPIM) :: IMYTID INTEGER(KIND=8) :: MAXMEM=0 ! For comparing memory between HEAPCHECK_START and HEAPCHECK_END #include "dr_hook_init.intfb.h" IF (.NOT.LDHOOK) RETURN IMYTID = OML_MY_THREAD() IF (.NOT.LL_INIT) THEN LL_INIT = .TRUE. CALL DR_HOOK_INIT() IF(.NOT.LHOOK) RETURN ! LHOOK is set to .TRUE. within DR_HOOK_INIT() only when envvar DR_HOOK=1 CALL DR_HACK_INIT() CALL STACKCHECK_INIT() CALL HEAPCHECK_INIT() ENDIF ! .NOT.LL_INIT IF (LL_STACKCHECK) CALL STACKCHECK() IF (KCASE == 0) THEN CALL C_DRHOOK_START(CDNAME, IMYTID, PKEY, CDFILENAME, KSIZEINFO) IF(LL_HEAPCHECK) CALL HEAPCHECK_START() ELSE IF (KCASE == 1) THEN IF(LL_HEAPCHECK) CALL HEAPCHECK_END() CALL C_DRHOOK_END (CDNAME, IMYTID, PKEY, CDFILENAME, KSIZEINFO) ENDIF IF (LL_DRHACK) THEN CALL DR_HACK(CDNAME,KCASE) ENDIF CALL GSTATS_FINDSUMB() ! currently only dead code within !-------------------- END SUBROUTINE DR_HOOK_UTIL ----------------- CONTAINS FUNCTION MYPROC() USE MPL_DATA_MODULE ,ONLY : MPL_NUMPROC USE MPL_MYRANK_MOD ,ONLY : MPL_MYRANK INTEGER(KIND=JPIM) :: MYPROC IF( MPL_NUMPROC > 0 ) THEN MYPROC = MPL_MYRANK() ELSE MYPROC = 1 ENDIF END FUNCTION MYPROC SUBROUTINE HEAPCHECK_INIT() IMPLICIT NONE CHARACTER(LEN=4) :: CHEAP !JFH---Initialisation to monitor heap usage----------------------- CALL GET_ENVIRONMENT_VARIABLE('DR_HOOK_HEAPCHECK',CHEAP) IF( CHEAP == 'yes' .OR. CHEAP == 'YES' .OR. & & CHEAP == 'true' .OR. CHEAP == 'TRUE' .OR. & & CHEAP == 'on' .OR. CHEAP == 'ON' .OR. & & CHEAP == '1' ) THEN LL_HEAPCHECK = .TRUE. IF(IMYTID == 1) THEN CALL SETHEAPCHECK() ENDIF ENDIF !JFH------------ End --------------------------------------------- END SUBROUTINE HEAPCHECK_INIT SUBROUTINE HEAPCHECK_START() !JFH---Code to monitor heap usage ------------------------- USE EC_LUN ,ONLY : NULERR IMPLICIT NONE INTEGER(KIND=8) :: GETMAXLOC INTEGER(KIND=8) :: GETMAXMEM IF(IMYTID == 1) THEN IF( MYPROC() == 1) THEN GETMAXMEM=GETMAXLOC() IF(GETMAXMEM .GT. MAXMEM) THEN MAXMEM = GETMAXMEM WRITE(NULERR,*) "HEAPCHECK Max heap at beg of routine =",MAXMEM," ",CDNAME ENDIF ENDIF ENDIF !JFH------------ End --------------------------------------------- END SUBROUTINE HEAPCHECK_START SUBROUTINE HEAPCHECK_END() !JFH---Code to monitor heap usage ------------------------- USE EC_LUN ,ONLY : NULERR IMPLICIT NONE INTEGER(KIND=8) :: GETMAXLOC INTEGER(KIND=8) :: GETMAXMEM IF(IMYTID == 1) THEN IF( MYPROC() == 1) THEN GETMAXMEM=GETMAXLOC() IF(GETMAXMEM .GT. MAXMEM) THEN MAXMEM = GETMAXMEM WRITE(NULERR,*) "HEAPCHECK Max heap at end of routine =",MAXMEM," ",CDNAME ENDIF ENDIF ENDIF !JFH------------ End --------------------------------------------- END SUBROUTINE HEAPCHECK_END SUBROUTINE STACKCHECK_INIT() USE DR_HOOK_STACKCHECK_MOD ,ONLY : LL_THREAD_FIRST,ISAVE,IMAXSTACK ! For monitoring thread stack usage USE OML_MOD ,ONLY : OML_MAX_THREADS IMPLICIT NONE INTEGER(KIND=JPIM) :: INUMTIDS CHARACTER(LEN=4) :: CSTACK !JFH---Initialisation to monitor stack usage by threads------------- CALL GET_ENVIRONMENT_VARIABLE('DR_HOOK_STACKCHECK',CSTACK) IF ( CSTACK == 'yes' .OR. CSTACK == 'YES' .OR. & & CSTACK == 'true' .OR. CSTACK == 'TRUE' .OR. & & CSTACK == 'on' .OR. CSTACK == 'ON' .OR. & & CSTACK == '1' ) THEN LL_STACKCHECK = .TRUE. IF(IMYTID == 1 ) THEN INUMTIDS = OML_MAX_THREADS() ALLOCATE(LL_THREAD_FIRST(INUMTIDS)) ALLOCATE(ISAVE(INUMTIDS)) ALLOCATE(IMAXSTACK(INUMTIDS)) LL_THREAD_FIRST=.TRUE. ISAVE=0 IMAXSTACK=0 ENDIF ENDIF !JFH------------ End --------------------------------------------- END SUBROUTINE STACKCHECK_INIT SUBROUTINE STACKCHECK() !JFH---Code to monitor stack usage by threads--------------------- #ifndef NAGFOR USE DR_HOOK_STACKCHECK_MOD ,ONLY : LL_THREAD_FIRST,ISAVE,IMAXSTACK USE EC_LUN ,ONLY : NULERR IMPLICIT NONE INTEGER(KIND=8) :: ILOC ! For monitoring thread stack usage IF(IMYTID > 1) THEN IF(LL_THREAD_FIRST(IMYTID))THEN LL_THREAD_FIRST(IMYTID)=.FALSE. ISAVE(IMYTID)=LOC(ILOC) ENDIF ILOC=LOC(ILOC) IF(ISAVE(IMYTID)-ILOC > IMAXSTACK(IMYTID)) THEN IMAXSTACK(IMYTID)=ISAVE(IMYTID)-ILOC WRITE(NULERR,'(A,I3,A,I12,2X,A)')"STACKCHECK Max stack usage by thread",IMYTID," =",IMAXSTACK(IMYTID),CDNAME ENDIF ENDIF #endif !JFH------------ End --------------------------------------------- END SUBROUTINE STACKCHECK SUBROUTINE GSTATS_FINDSUMB() !GM---Code to find gstats SUMB time------------------------------- !!!! Willem Deconinck - June 2021: !!!! Note following code was dead as LLFINDSUMB = .FALSE. hardcoded. !!!! From gstats.F90 documentation: LLFINDSUMB - when set is used detect gstat counter problems. !!!! If agreed, this could be removed altogether, and remove dependency of dr_hook on gstats !!!! Now removed from compilation with #if 0 #if 0 USE YOMGSTATS, ONLY : LAST_KNUM,LAST_KSWITCH,LDETAILED_STATS,MYPROC_STATS, & NHOOK_MESSAGES,TIME_LAST_CALL IMPLICIT NONE LOGICAL, PARAMETER :: LLFINDSUMB=.FALSE. REAL(KIND=JPRD) :: ZCLOCK REAL(KIND=JPRD) :: ZDIFF CHARACTER(LEN=7) CLSTR IF( LDETAILED_STATS .AND. LLFINDSUMB )THEN IF( IMYTID==1 .AND. LAST_KNUM>=500 .AND. MYPROC_STATS <= 2 )THEN IF( LAST_KSWITCH==1 .OR. LAST_KSWITCH==2 )THEN CALL USER_CLOCK(PELAPSED_TIME=ZCLOCK) ZDIFF=ZCLOCK-TIME_LAST_CALL IF( ZDIFF > 0.1_JPRD )THEN IF( KCASE == 0 )THEN CLSTR='ENTERED' ELSE CLSTR='EXITED' ENDIF IF( NHOOK_MESSAGES < 100000 )THEN WRITE(0,'("DR_HOOK_UTIL: ",A,2X,A," TIMESUMB=",F10.6)')CDNAME,CLSTR,ZDIFF NHOOK_MESSAGES=NHOOK_MESSAGES+1 ENDIF ENDIF ENDIF ENDIF ENDIF #endif !GM------------ End --------------------------------------------- END SUBROUTINE GSTATS_FINDSUMB END SUBROUTINE DR_HOOK_UTIL fiat-ecmwf-2.0.0/src/fiat/drhook/internal/crc.h0000664000175000017500000000277615157200431021465 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* crc.h */ /* Calculates 32-bit Cyclic Redundancy Check as in Unix cksum command */ /* Also calculates 64-bit Cyclic Redundancy Check */ /* Sami Saarinen, 17-Feb-2005 : crc32 */ /* 24-Jun-2005 : Added crc64 */ /* 29-Dec-2005 : Added protos for direct C-calls */ /* 29-Dec-2005 : Length argument for crc64 now 64-bit int */ /* C callables */ extern unsigned int pp_cksum32(int nbuf, unsigned int nCRC); extern unsigned int pp_cksum32but64len(long long int nbuf, unsigned int nCRC); extern unsigned long long int pp_cksum64(long long int nbuf, unsigned long long int nCRC); extern unsigned int cksum32(const char *buf, int nbuf, unsigned int nCRC); extern unsigned long long int cksum64(const char *buf, long long int nbuf, unsigned long long int nCRC); /* Fortran callable */ extern void crc32_(const void *vbuf, const int *pnbuf, unsigned int *pnCRC /* Note: An in & out -variable */); extern void crc64_(const void *vbuf, const long long int *pnbuf, unsigned long long int *pnCRC /* Note: An in & out -variable */); fiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_init.intfb.h0000664000175000017500000000075515157200431024462 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE DR_HOOK_INIT END SUBROUTINE DR_HOOK_INIT END INTERFACEfiat-ecmwf-2.0.0/src/fiat/drhook/internal/dr_hook_end.intfb.h0000664000175000017500000000075315157200431024263 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE DR_HOOK_END END SUBROUTINE DR_HOOK_END END INTERFACEfiat-ecmwf-2.0.0/src/fiat/drhook/dr_hook_end.F900000664000175000017500000000131315157200431021446 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE DR_HOOK_END() ! Make sure DrHook output is produced before MPI_Finalize (in case it fails) IMPLICIT NONE EXTERNAL :: c_drhook_prof LOGICAL,SAVE :: LL_FIRST_TIME = .TRUE. IF( .NOT. LL_FIRST_TIME ) THEN LL_FIRST_TIME = .FALSE. CALL c_drhook_prof() ENDIF END SUBROUTINEfiat-ecmwf-2.0.0/src/fiat/drhook/dr_hook_watch_mod.F900000664000175000017500000002466515157200431022664 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE DR_HOOK_WATCH_MOD USE EC_PARKIND ,ONLY : JPRD, JPIM, JPIB, JPRM !-- Watch point creation interface for Dr.Hook IMPLICIT NONE SAVE PRIVATE INTEGER, PUBLIC, PARAMETER :: KEYNONE = 0 INTEGER, PUBLIC, PARAMETER :: KEYLOG = 1 INTEGER, PUBLIC, PARAMETER :: KEYCHAR = 2 INTEGER, PUBLIC, PARAMETER :: KEY_I4 = 4 INTEGER, PUBLIC, PARAMETER :: KEY_I8 = 8 INTEGER, PUBLIC, PARAMETER :: KEY_R4 = 16 INTEGER, PUBLIC, PARAMETER :: KEY_R8 = 32 INTERFACE DR_HOOK_WATCH MODULE PROCEDURE & DR_HOOK_WATCH_CHARACTER, & DR_HOOK_WATCH_LOGICAL_SCALAR, & DR_HOOK_WATCH_LOGICAL_VEC, & DR_HOOK_WATCH_I4_SCALAR, & DR_HOOK_WATCH_I4_VEC, & DR_HOOK_WATCH_I8_SCALAR, & DR_HOOK_WATCH_I8_VEC, & DR_HOOK_WATCH_R4_SCALAR, & DR_HOOK_WATCH_R4_VEC, & DR_HOOK_WATCH_R8_SCALAR, & DR_HOOK_WATCH_R8_VEC END INTERFACE PUBLIC :: DR_HOOK_WATCH PUBLIC :: DR_HOOK_CHECK_WATCH CONTAINS SUBROUTINE CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, IPRTKEY, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) LOGICAL, INTENT(INOUT) :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM), INTENT(OUT) :: IABORT, IACTIVE, IPRINT, ITRBK INTEGER(KIND=JPIM), INTENT(IN) :: IPRTKEY LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK IABORT = 0 LLABORT = .TRUE. IF (PRESENT(LDABORT)) LLABORT = LDABORT IF (LLABORT) IABORT = 1 IACTIVE = 0 LLACTIVE = .TRUE. IF (PRESENT(LDACTIVE)) LLACTIVE = LDACTIVE IF (LLACTIVE) IACTIVE = 1 IPRINT = KEYNONE LLPRINT = .TRUE. IF (PRESENT(LDPRINT)) LLPRINT = LDPRINT IF (LLPRINT) IPRINT = IPRTKEY ITRBK = 0 LLTRBK = .FALSE. IF (PRESENT(LDTRBK)) LLTRBK = LDTRBK IF (LLTRBK) ITRBK = 1 END SUBROUTINE CHECK_ARGS SUBROUTINE DR_HOOK_WATCH_CHARACTER(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 1 CHARACTER(LEN=*), INTENT(IN) :: CDNAME CHARACTER(LEN=*), INTENT(IN) :: PTR LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = LEN(PTR) * JP_BYTES_PER_ELEM IF (IBYTES <= 0) RETURN CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEYCHAR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR(1:1), IBYTES, IABORT, IPRINT, LEN(PTR), ITRBK) END SUBROUTINE DR_HOOK_WATCH_CHARACTER SUBROUTINE DR_HOOK_WATCH_LOGICAL_SCALAR(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4 CHARACTER(LEN=*), INTENT(IN) :: CDNAME LOGICAL, INTENT(IN) :: PTR LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = JP_BYTES_PER_ELEM CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEYLOG, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR, IBYTES, IABORT, IPRINT, 1, ITRBK) END SUBROUTINE DR_HOOK_WATCH_LOGICAL_SCALAR SUBROUTINE DR_HOOK_WATCH_LOGICAL_VEC(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4 CHARACTER(LEN=*), INTENT(IN) :: CDNAME LOGICAL, INTENT(IN) :: PTR(:) LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = SIZE(PTR) * JP_BYTES_PER_ELEM IF (IBYTES <= 0) RETURN CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR(1), IBYTES, IABORT, IPRINT, SIZE(PTR), ITRBK) END SUBROUTINE DR_HOOK_WATCH_LOGICAL_VEC SUBROUTINE DR_HOOK_WATCH_I4_SCALAR(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4 CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: PTR LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = JP_BYTES_PER_ELEM CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_I4, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR, IBYTES, IABORT, IPRINT, 1, ITRBK) END SUBROUTINE DR_HOOK_WATCH_I4_SCALAR SUBROUTINE DR_HOOK_WATCH_I4_VEC(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4 CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: PTR(:) LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = SIZE(PTR) * JP_BYTES_PER_ELEM IF (IBYTES <= 0) RETURN CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_I4, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR(1), IBYTES, IABORT, IPRINT, SIZE(PTR), ITRBK) END SUBROUTINE DR_HOOK_WATCH_I4_VEC SUBROUTINE DR_HOOK_WATCH_I8_SCALAR(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8 CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIB), INTENT(IN) :: PTR LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = JP_BYTES_PER_ELEM CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_I8, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR, IBYTES, IABORT, IPRINT, 1, ITRBK) END SUBROUTINE DR_HOOK_WATCH_I8_SCALAR SUBROUTINE DR_HOOK_WATCH_I8_VEC(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8 CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIB), INTENT(IN) :: PTR(:) LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = SIZE(PTR) * JP_BYTES_PER_ELEM IF (IBYTES <= 0) RETURN CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_I8, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR(1), IBYTES, IABORT, IPRINT, SIZE(PTR), ITRBK) END SUBROUTINE DR_HOOK_WATCH_I8_VEC SUBROUTINE DR_HOOK_WATCH_R4_SCALAR(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4 CHARACTER(LEN=*), INTENT(IN) :: CDNAME REAL(KIND=JPRM), INTENT(IN) :: PTR LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = JP_BYTES_PER_ELEM CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_R4, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR, IBYTES, IABORT, IPRINT, 1, ITRBK) END SUBROUTINE DR_HOOK_WATCH_R4_SCALAR SUBROUTINE DR_HOOK_WATCH_R4_VEC(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 4 CHARACTER(LEN=*), INTENT(IN) :: CDNAME REAL(KIND=JPRM), INTENT(IN) :: PTR(:) LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = SIZE(PTR) * JP_BYTES_PER_ELEM IF (IBYTES <= 0) RETURN CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_R4, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR(1), IBYTES, IABORT, IPRINT, SIZE(PTR), ITRBK) END SUBROUTINE DR_HOOK_WATCH_R4_VEC SUBROUTINE DR_HOOK_WATCH_R8_SCALAR(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8 CHARACTER(LEN=*), INTENT(IN) :: CDNAME REAL(KIND=JPRD), INTENT(IN) :: PTR LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = JP_BYTES_PER_ELEM CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_R8, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR, IBYTES, IABORT, IPRINT, 1, ITRBK) END SUBROUTINE DR_HOOK_WATCH_R8_SCALAR SUBROUTINE DR_HOOK_WATCH_R8_VEC(CDNAME, PTR, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) INTEGER(KIND=JPIM), PARAMETER :: JP_BYTES_PER_ELEM = 8 CHARACTER(LEN=*), INTENT(IN) :: CDNAME REAL(KIND=JPRD), INTENT(IN) :: PTR(:) LOGICAL, INTENT(IN), OPTIONAL :: LDABORT, LDACTIVE, LDPRINT, LDTRBK LOGICAL :: LLABORT, LLACTIVE, LLPRINT, LLTRBK INTEGER(KIND=JPIM) :: IBYTES, IABORT, IACTIVE, IPRINT, ITRBK IBYTES = SIZE(PTR) * JP_BYTES_PER_ELEM IF (IBYTES <= 0) RETURN CALL CHECK_ARGS(LLABORT, LLACTIVE, LLPRINT, LLTRBK, & & IABORT, IACTIVE, IPRINT, ITRBK, KEY_R8, & & LDABORT, LDACTIVE, LDPRINT, LDTRBK) CALL C_DRHOOK_WATCH(IACTIVE, CDNAME, PTR(1), IBYTES, IABORT, IPRINT, SIZE(PTR), ITRBK) END SUBROUTINE DR_HOOK_WATCH_R8_VEC SUBROUTINE DR_HOOK_CHECK_WATCH(CDWHERE, LDABORT) CHARACTER(LEN=*), INTENT(IN) :: CDWHERE LOGICAL, INTENT(IN), OPTIONAL :: LDABORT LOGICAL :: LLABORT INTEGER(KIND=JPIM) :: IABORT IABORT = 0 LLABORT = .FALSE. IF (PRESENT(LDABORT)) LLABORT = LDABORT IF (LLABORT) IABORT = 1 CALL C_DRHOOK_CHECK_WATCH(CDWHERE, IABORT) END SUBROUTINE DR_HOOK_CHECK_WATCH END MODULE DR_HOOK_WATCH_MOD fiat-ecmwf-2.0.0/src/fiat/drhook/yomhook.F900000664000175000017500000001213615157200431020665 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE YOMHOOK USE EC_PARKIND ,ONLY : JPIM, JPRM, JPRD IMPLICIT NONE ! Used by "hook" function ! LHOOK = true implies "hook" function will be called ! Altough initialized to TRUE it will be reset by first call to ! DR_HOOK unless we really want to use the hook function SAVE PRIVATE :: JPIM, JPRM, JPRD PUBLIC INTEGER, PARAMETER :: JPHOOK = SELECTED_REAL_KIND(13,300) LOGICAL :: LHOOK=.TRUE. #include "dr_hook_util.h" #include "dr_hook_util_multi.h" #include "dr_hook_init.intfb.h" #include "dr_hook_end.intfb.h" INTERFACE DR_HOOK ! We want compile time mapping of DR_HOOK-arguments and not ! to test OPTIONAL-arguments with PRESENT()-function, since ! it costs more. ! However, this "unrolling" approach cannot be streched much more ! than this without making number of member-functions too large ! (i.e. all the possible permutations of these "optional" args; ! arguments that are not present in the DR_HOOK_DEFAULT -version) MODULE PROCEDURE & #ifdef DR_HOOK_MULTI_PRECISION_HANDLES DR_HOOK_DEFAULT4, & #endif DR_HOOK_DEFAULT8, & DR_HOOK_FILE, & DR_HOOK_SIZE, & DR_HOOK_FILE_SIZE, & DR_HOOK_MULTI_DEFAULT, & DR_HOOK_MULTI_FILE, & DR_HOOK_MULTI_SIZE, & DR_HOOK_MULTI_FILE_SIZE END INTERFACE CONTAINS SUBROUTINE DR_HOOK_DEFAULT4(CDNAME,KSWITCH,PKEY) !! This overload only works when DR_HOOK_MULTI_PRECISION_HANDLES is defined !! This also assumes that DR_HOOK_NCALLSTACK > 0 (e.g. DR_HOOK_NCALLSTACK=64) CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH REAL(KIND=JPRM), INTENT(INOUT) :: PKEY REAL(KIND=JPRD) :: ZKEY ZKEY = TRANSFER(PKEY,ZKEY) CALL DR_HOOK_UTIL(LHOOK,CDNAME,KSWITCH,ZKEY,'',0_JPIM) PKEY = TRANSFER(ZKEY,PKEY) END SUBROUTINE DR_HOOK_DEFAULT4 SUBROUTINE DR_HOOK_DEFAULT8(CDNAME,KSWITCH,PKEY) CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH REAL(KIND=JPRD), INTENT(INOUT) :: PKEY !REAL(KIND=JPRD) :: ZKEY !ZKEY = TRANSFER(PKEY,ZKEY) CALL DR_HOOK_UTIL(LHOOK,CDNAME,KSWITCH,PKEY,'',0_JPIM) !PKEY = TRANSFER(ZKEY,PKEY) END SUBROUTINE DR_HOOK_DEFAULT8 SUBROUTINE DR_HOOK_MULTI_DEFAULT(CDNAME,KSWITCH,PKEY) CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH REAL(KIND=JPRD), INTENT(INOUT) :: PKEY(:) CALL DR_HOOK_UTIL_MULTI(LHOOK,CDNAME,KSWITCH,PKEY,INT(SIZE(PKEY)),'',0_JPIM) END SUBROUTINE DR_HOOK_MULTI_DEFAULT SUBROUTINE DR_HOOK_FILE(CDNAME,KSWITCH,PKEY,CDFILE) CHARACTER(LEN=*), INTENT(IN) :: CDNAME,CDFILE INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH REAL(KIND=JPRD), INTENT(INOUT) :: PKEY CALL DR_HOOK_UTIL(LHOOK,CDNAME,KSWITCH,PKEY,CDFILE,0_JPIM) END SUBROUTINE DR_HOOK_FILE SUBROUTINE DR_HOOK_MULTI_FILE(CDNAME,KSWITCH,PKEY,CDFILE) CHARACTER(LEN=*), INTENT(IN) :: CDNAME,CDFILE INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH REAL(KIND=JPRD), INTENT(INOUT) :: PKEY(:) CALL DR_HOOK_UTIL_MULTI(LHOOK,CDNAME,KSWITCH,PKEY,INT(SIZE(PKEY)),CDFILE,0_JPIM) END SUBROUTINE DR_HOOK_MULTI_FILE SUBROUTINE DR_HOOK_SIZE(CDNAME,KSWITCH,PKEY,KSIZEINFO) CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH,KSIZEINFO REAL(KIND=JPRD), INTENT(INOUT) :: PKEY CALL DR_HOOK_UTIL(LHOOK,CDNAME,KSWITCH,PKEY,'',KSIZEINFO) END SUBROUTINE DR_HOOK_SIZE SUBROUTINE DR_HOOK_MULTI_SIZE(CDNAME,KSWITCH,PKEY,KSIZEINFO) CHARACTER(LEN=*), INTENT(IN) :: CDNAME INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH,KSIZEINFO REAL(KIND=JPRD), INTENT(INOUT) :: PKEY(:) CALL DR_HOOK_UTIL_MULTI(LHOOK,CDNAME,KSWITCH,PKEY,INT(SIZE(PKEY)),'',KSIZEINFO) END SUBROUTINE DR_HOOK_MULTI_SIZE SUBROUTINE DR_HOOK_FILE_SIZE(CDNAME,KSWITCH,PKEY,CDFILE,KSIZEINFO) CHARACTER(LEN=*), INTENT(IN) :: CDNAME,CDFILE INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH,KSIZEINFO REAL(KIND=JPRD), INTENT(INOUT) :: PKEY CALL DR_HOOK_UTIL(LHOOK,CDNAME,KSWITCH,PKEY,CDFILE,KSIZEINFO) END SUBROUTINE DR_HOOK_FILE_SIZE SUBROUTINE DR_HOOK_MULTI_FILE_SIZE(CDNAME,KSWITCH,PKEY,CDFILE,KSIZEINFO) CHARACTER(LEN=*), INTENT(IN) :: CDNAME,CDFILE INTEGER(KIND=JPIM), INTENT(IN) :: KSWITCH,KSIZEINFO REAL(KIND=JPRD), INTENT(INOUT) :: PKEY(:) CALL DR_HOOK_UTIL_MULTI(LHOOK,CDNAME,KSWITCH,PKEY,INT(SIZE(PKEY)),CDFILE,KSIZEINFO) END SUBROUTINE DR_HOOK_MULTI_FILE_SIZE SUBROUTINE DR_HOOK_CALLTREE(KTID) USE OML_MOD ,ONLY : OML_MY_THREAD INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KTID INTEGER(KIND=JPIM) :: IPRINT_OPTION ! may not be parameter INTEGER(KIND=JPIM) :: ILEVEL ! may not be parameter INTEGER(KIND=JPIM) :: ITID IF (LHOOK) THEN IF (PRESENT(KTID)) THEN ITID = KTID ELSE ITID = OML_MY_THREAD() ENDIF IPRINT_OPTION = 2 ILEVEL = 99 CALL C_DRHOOK_PRINT(0, ITID, IPRINT_OPTION, ILEVEL) ! from drhook.c ENDIF END SUBROUTINE END MODULE YOMHOOK fiat-ecmwf-2.0.0/src/fiat/drhook/drhook.c0000664000175000017500000053102515157200431020355 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #define _DRHOOK_C_ 1 #define _DRHOOK_FILE_ "drhook.c" #define _GNU_SOURCE /* drhook.c Author: Sami Saarinen, ECMWF, 14..24-Nov-2003 Thanks to Bob Walkup & John Hague for IBM Power4 version Thanks to Bob Carruthers for Cray X1 (SV2), XD1 and XT3 versions, as well as David Tanqueray for the flop routines Also thanks to Roland Richter for suggesting the use of "call tracebackqq()" function. In our environment this is accomplished by calling fortran routine intel_trbk() from ifsaux/utilities/gentrbk.F90. Please pay attention also to the mother of all tracebacks produced under ifsaux/utilities/linuxtrbk.c and the C++ utility cxxdemangle() in ifsaux/utilities/cxxdemangle.cc */ #include #if defined(__APPLE__) #include #endif #if !defined(HOST_NAME_MAX) && defined(_POSIX_HOST_NAME_MAX) #define HOST_NAME_MAX _POSIX_HOST_NAME_MAX #endif #if !defined(HOST_NAME_MAX) && defined(_SC_HOST_NAME_MAX) #define HOST_NAME_MAX _SC_HOST_NAME_MAX #endif #if defined(HOST_NAME_MAX) #define EC_HOST_NAME_MAX HOST_NAME_MAX #else #define EC_HOST_NAME_MAX 512 #endif /* === This doesn't handle recursive calls correctly (yet) === */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #ifdef __NEC__ static int backtrace(void **buffer, int size) { return 0; } #else #include #endif #include #include "drhook.h" #include "cas.h" #include "oml.h" #include #include #include #include // Extension headers #ifdef DR_HOOK_HAVE_NVTX #include "dr_hook_nvtx.h" #endif #ifdef DR_HOOK_HAVE_ROCTX #include "dr_hook_roctx.h" #endif #ifdef DR_HOOK_HAVE_PAPI #include "drhook_papi.h" #else // This type is in the signature of remove_calltree() #define long_long long long #endif #include "ec_get_cycles.h" static long long int *thread_cycles = NULL; int drhook_lhook = 1; // NOTE: A global variable !! #ifdef __timer_t_defined #define _DRHOOK_TIMER_T_ #else #undef _DRHOOK_TIMER_T_ #endif static void set_timed_kill(); static void process_options(); static char *TimeStr(char *s, int slen); static oml_lock_t DRHOOK_lock = 0; static int drhook_oml_get_thread_num() { // Equivalent to omp_get_thread_num() + 1 return oml_my_thread(); } static int drhook_oml_get_num_threads() { // Equivalent to omp_get_num_threads() --> currently active threads (!= max_threads) return oml_get_num_threads(); } static int drhook_oml_get_max_threads() { // Equivalent to omp_get_max_threads() return oml_get_max_threads(); } #if 0 // unused static int drhook_oml_test_lock() { return oml_test_lockid(&DRHOOK_lock); } #endif static void drhook_oml_set_lock() { oml_set_lockid(&DRHOOK_lock); } static void drhook_oml_unset_lock() { oml_unset_lockid(&DRHOOK_lock); } static void drhook_oml_init_lock() { char *env = getenv("DR_HOOK_SHOW_LOCK"); /* export DR_HOOK_SHOW_LOCK=1 to show the lock-info */ int konoff = env ? atoi(env) : 0; int saved_state = oml_get_debug(); if (konoff == 1) { oml_set_debug(konoff); } oml_init_lockid_with_name(&DRHOOK_lock, "drhook.c:DRHOOK_lock"); oml_set_debug(saved_state); } #if !defined(CACHELINESIZE) #if defined(LEVEL1_DCACHE_LINESIZE) #define CACHELINESIZE LEVEL1_DCACHE_LINESIZE #else /* ***Note: A hardcoded cache line size in bytes !!! */ #define CACHELINESIZE 64 #endif #endif #include "crc.h" #include static char *start_stamp = NULL; static char *end_stamp = NULL; static int numthreads = 0; static int myproc = 1; static int nproc = -1; //static int max_threads = 1; typedef struct drhook_prefix_t { char s[3840]; char timestr[256]; int nsigs; } drhook_prefix_t; static drhook_prefix_t *ec_drhook = NULL; static int timestr_len = 0; #define PREFIX(tid) (ec_drhook && tid >= 1 && tid <= numthreads) ? ec_drhook[tid-1].s : "" #define TIDNSIGS(tid) (ec_drhook && tid >= 1 && tid <= numthreads) ? ec_drhook[tid-1].nsigs : -1 #define TIMESTR(tid) (timestr_len > 0 && ec_drhook && tid >= 1 && tid <= numthreads) ? TimeStr(ec_drhook[tid-1].timestr,timestr_len) : "" #define FFL __FUNCTION__,_DRHOOK_FILE_,__LINE__ static int drhook_trapfpe_master_init = 0; static int drhook_trapfpe = 1; static int drhook_trapfpe_invalid = 1; static int drhook_trapfpe_divbyzero = 1; static int drhook_trapfpe_overflow = 1; #if (defined(LINUX) || defined(__APPLE__)) && !defined(CYGWIN) #if (defined(__GNUC__) || defined(__PGI)) && !defined(NO_TRAPFPE) #include extern int feenableexcept(int excepts); extern int fedisableexcept(int excepts); extern int fegetexcept(void); #if defined(__APPLE__) /* A temporary fix to link on macOS. Something more clever will be done later -REK. */ int feenableexcept (int excepts) { return 0; } int fedisableexcept(int excepts) { return 0; } int fegetexcept(void) { return 0; } #endif #if defined(__NEC__) int fegetexcept(void) { return 0; } #endif static void trapfpe(int silent) { /* Enable some exceptions. At startup all exceptions are masked. */ /* New coding -- honours DR_HOOK_TRAPFPE_{INVALID,DIVBYZERO,OVERLOW} set to 1 (or 0) */ int tid = drhook_oml_get_thread_num(); int enable = 0; int disable = 0; int rc_enable = 0; int rc_disable = 0; int excepts_before = 0; int excepts_after = 0; if( drhook_trapfpe_invalid ) { enable |= FE_INVALID; } else { disable |= FE_INVALID; } if( drhook_trapfpe_divbyzero ) { enable |= FE_DIVBYZERO; } else { disable |= FE_DIVBYZERO; } if( drhook_trapfpe_overflow ) { enable |= FE_OVERFLOW; } else { disable |= FE_OVERFLOW; } if (!silent && myproc == 1) { excepts_before = fegetexcept(); } if (enable) rc_enable = feenableexcept(enable); // Turn ON these if (disable) rc_disable = fedisableexcept(disable); // Turn OFF these if (!silent && myproc == 1) { char *pfx = PREFIX(tid); excepts_after = fegetexcept(); fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK trapfpe() : Exceptions before = 0x%x [%d] -- after = 0x%x [%d]\n", pfx,TIMESTR(tid),FFL, excepts_before, excepts_before, excepts_after, excepts_after); fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK trapfpe() : with FE_INVALID = 0x%x [%d] -- FE_DIVBYZERO = 0x%x [%d] -- FE_OVERFLOW = 0x%x [%d]\n", pfx,TIMESTR(tid),FFL, (int)FE_INVALID, (int)FE_INVALID, (int)FE_DIVBYZERO, (int)FE_DIVBYZERO, (int)FE_OVERFLOW, (int)FE_OVERFLOW); if (enable) { fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK trapfpe() : feenableexcept(0x%x [%d]) returns rc=%d\n", pfx,TIMESTR(tid),FFL, enable,enable,rc_enable); } if (disable) { fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK trapfpe() : fedisableexcept(0x%x [%d]) returns rc=%d\n", pfx,TIMESTR(tid),FFL, disable,disable,rc_disable); } if (tid == 1) drhook_trapfpe_master_init = 1; // go-ahead for slave threads in trapfpe_slave_threads() } } static void untrapfpe(int silent) { /* Disable some exceptions. At startup all exceptions are masked. */ int rc = fedisableexcept(FE_INVALID|FE_DIVBYZERO|FE_OVERFLOW); } #endif /* (defined(__GNUC__) || defined(__PGI)) && !defined(NO_TRAPFPE) */ #endif /* (defined(LINUX) || defined(__APPLE__) && !defined(CYGWIN) */ #if (!(defined(LINUX) || defined(__APPLE__)) || defined(CYGWIN) || defined(NO_TRAPFPE)) && defined(__GNUC__) /* For example Solaris with gcc */ #define trapfpe(x) #define untrapfpe(x) #endif #ifndef drhook_harakiri_timeout_default #define drhook_harakiri_timeout_default 500 #endif static int drhook_harakiri_timeout = drhook_harakiri_timeout_default; static int drhook_use_lockfile = 1; static const char drhook_lockfile[] = "drhook_lock"; static int atp_enabled = 0; /* Cray ATP specific */ static int atp_max_cores = 20; /* Cray ATP specific */ static int atp_max_analysis_time = 300; /* Cray ATP specific */ static int atp_ignore_sigterm = 0; /* Cray ATP specific */ static int any_memstat = 0; static int opt_gethwm = 0; static int opt_getstk = 0; static int opt_getrss = 0; static int opt_getpag = 0; static int opt_walltime = 0; static int opt_cputime = 0; static int opt_wallprof = 0; static int opt_papi = 0; static int opt_cpuprof = 0; static int opt_memprof = 0; static int opt_cycles = 0; static int opt_trim = 0; static int opt_calls = 0; static int opt_self = 1; /* 0=exclude drhook altogether, 1=include, but don't print, 2=also print */ static int opt_propagate_signals = 1; static int opt_sizeinfo = 1; static int opt_clusterinfo = 0; static int opt_callpath = 0; #define callpath_indent_default 2 static int callpath_indent = callpath_indent_default; #define callpath_depth_default 50 static int callpath_depth = callpath_depth_default; static int callpath_packed = 0; static int opt_nvtx = 0; #define nvtx_SCC_default 10 static int opt_nvtx_SCC = nvtx_SCC_default; #define nvtx_SWT_default 0.0001 static double opt_nvtx_SWT = nvtx_SWT_default; static int opt_roctx = 0; #define roctx_SCC_default 10 static int opt_roctx_SCC = roctx_SCC_default; #define roctx_SWT_default 0.0001 static double opt_roctx_SWT = roctx_SWT_default; static int opt_strict_regions = 0; static int opt_silent = 0; static int opt_calltrace = 0; static int opt_funcenter = 0; static int opt_funcexit = 0; static int opt_timeline = 0; /* myproc or -1 [or 0 for --> timeline feature off (default)] */ static int opt_timeline_thread = 1; /* thread-id control : <= 0 print for all threads 1 -> #1 only [but curheap still SUM of all threads] (default), n -> print for increasing number of threads separately : [1..n] */ static int opt_timeline_format = 1; /* if 1, print only {wall,hwm,rss,curheap} w/o labels "wall=" etc.; else fully expanded fmt */ static int opt_timeline_unitno = 6; /* Fortran unit number : default = 6 i.e. stdout */ static long long int opt_timeline_freq = 1000000; /* How often to print : every n-th call : default = every 10^6 th call or ... */ static double opt_timeline_MB = 1.0; /* ... rss or curheap jumps up/down by more than this many MBytes (default = 1) : unit MBytes */ static volatile sig_atomic_t opt_gencore = 0; static int opt_gencore_signal = 0; static int opt_random_memstat = 0; /* > 0 if to obtain random memory stats (maxhwm, maxstk) for tid=1. Updated when rand() % opt_random_memstat == 0 */ static double opt_trace_stack = 0; /* if > 0, a multiplier for OMP_STACKSIZE to monitor high master thread stack usage -- -- implies opt_random_memstat = 1 (regardless of DR_HOOK_RANDOM_MEMSTAT setting) -- for master MPI task only (for the moment) */ static long long int drhook_oml_stacksize = 0; /* Slave stack size -- an indicative stack size even master thread should not exceed */ static long long int drhook_stacksize_threshold = 0; static long long int slave_stacksize(); /* Begin of developer options */ static char *drhook_timed_kill = NULL; /* Timer assisted simulated kill of procs/threads by signal */ static int drhook_dump_maps = 0; /* Print /proc//maps from signal handler (before moving to ATP or below) */ static int drhook_dump_smaps = 0; /* Print /proc//smaps from signal handler (before moving to ATP or below) */ static int drhook_dump_buddyinfo = 0; /* Print /proc/buddyinfo from signal handler (before moving to ATP or below) */ static int drhook_dump_meminfo = 0; /* Print /proc/meminfo from signal handler (before moving to ATP or below) */ static int drhook_dump_hugepages = 0; static double drhook_dump_hugepages_freq = 0; /* End of developer options */ typedef struct drhook_timeline_t { unsigned long long int calls[2]; /* 0=drhook_begin , 1=drhook_end */ double last_curheap_MB; double last_rss_MB; double last_stack_MB; double last_vmpeak_MB; //#if CACHELINESIZE > (2*sizeof(unsigned long long int) + 4*sizeof(double)) -- disallowed #if CACHELINESIZE > (2*8 + 4*8) char pad[CACHELINESIZE - (2*sizeof(unsigned long long int) + 4*sizeof(double))]; /* padding : e.g. 64 bytes - 6*8 bytes */ #endif } drhook_timeline_t; /* cachelinesize optimized --> less false sharing when running with OpenMP */ static drhook_timeline_t *timeline = NULL; #define DRHOOK_STRBUF 1000 #ifndef SA_SIGINFO #define SA_SIGINFO 0 #define SIG_EXTRA_ARGS /* empty */ #define SIG_PASS_EXTRA_ARGS /* empty */ #else #define SIG_EXTRA_ARGS , siginfo_t *sigcode, void *sigcontextptr #define SIG_PASS_EXTRA_ARGS , sigcode, sigcontextptr #endif #define NIL "(nil)" #undef MIN #define MIN(a,b) ( (a) < (b) ? (a) : (b) ) #undef MAX #define MAX(a,b) ( (a) > (b) ? (a) : (b) ) #undef ABS #define ABS(x) ( (x) >= 0 ? (x) : -(x) ) #define strequ(s1,s2) ((void *)s1 && (void *)s2 && strcmp(s1,s2) == 0) #define strnequ(s1,s2,n) ((void *)s1 && (void *)s2 && memcmp(s1,s2,n) == 0) extern long long int getstk_(); extern long long int getmaxstk_(); extern long long int gethwm_(); extern long long int getmaxhwm_(); extern long long int getrss_(); extern long long int getmaxrss_(); extern long long int getcurheap_(); extern long long int getmaxcurheap_(); extern long long int getcurheap_thread_(const int *tidnum); /* *tidnum >= 1 && <= max_threads */ extern long long int getmaxcurheap_thread_(const int *tidnum); /* *tidnum >= 1 && <= max_threads */ extern long long int getpag_(); extern long long int getvmpeak_(); extern void ec_set_umask_(); extern double util_cputime_(); extern double util_walltime_(); #define WALLTIME() util_walltime_() #define CPUTIME() util_cputime_() #include "abor1.h" #include "ec_args.h" static drhook_abort_t drhook_abort_funptr = NULL; void drhook_set_abort( drhook_abort_t abort_funptr ) { drhook_abort_funptr = abort_funptr; } void drhook_abort( const char* file, int line, const char* txt ) { if( drhook_abort_funptr ) { drhook_abort_funptr( file, line, txt ); } else { abor1( file, line, txt ); } _exit(1); // should not be here } #define DRHOOK_ABORT() \ drhook_abort( _DRHOOK_FILE_, __LINE__, "*** Fatal error; drhook_abort ..." ) extern void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr); extern void intel_trbk_(); /*** typedefs ***/ typedef union { struct drhook_key_t *keyptr; double d; unsigned long long int ull; } equivalence_t; typedef struct drhook_key_t { char *name; unsigned short name_len; const equivalence_t *callpath; /* parent's tree down to callpath_depth */ int callpath_len; unsigned int callpath_fullhash; unsigned short status; /* 0=inactive, >1 active */ unsigned long long int calls; long long int hwm, maxrss, rssnow, stack, maxstack, paging; double wall_in, delta_wall_all, delta_wall_child; double cpu_in, delta_cpu_all, delta_cpu_child; long long int cycles_in, delta_cycles_all, delta_cycles_child; char *filename; /* the filename where the 1st call (on this routine-name) to dr_hook() occurred */ long long int sizeinfo; /* # of data elements, bytes, etc. */ long long int min_sizeinfo, max_sizeinfo; /* min & max of # of data elements, bytes, etc. */ /* memprof specific */ long long int mem_seenmax; long long int mem_child, mem_curdelta; long long int maxmem_selfdelta, maxmem_alldelta; long long int mem_maxhwm, mem_maxrss, mem_maxstk, mem_maxpagdelta; long long int paging_in; #if defined(DR_HOOK_HAVE_PAPI) long_long counters_in[MAXNPAPICNTRS]; long_long delta_counters_all[MAXNPAPICNTRS]; long_long delta_counters_child[MAXNPAPICNTRS]; #endif unsigned long long int alloc_count, free_count; #if defined(DR_HOOK_HAVE_NVTX) unsigned long long int skipped_nvtx_calls; #endif #if defined(DR_HOOK_HAVE_ROCTX) unsigned long long int skipped_roctx_calls; #endif struct drhook_key_t *next; } drhook_key_t; typedef struct drhook_calltree_t { int active; drhook_key_t *keyptr; struct drhook_calltree_t *next; struct drhook_calltree_t *prev; } drhook_calltree_t; typedef struct drhook_sig_t { char name[32]; struct sigaction new; struct sigaction old; int active; int ignore_atexit; } drhook_sig_t; typedef union { void (*func1args)(int sig); void (*func3args)(int sig SIG_EXTRA_ARGS); } drhook_sigfunc_t; typedef struct drhook_prof_t { double pc; double total; double self; #if defined(DR_HOOK_HAVE_PAPI) long_long counter_tot[MAXNPAPICNTRS]; long_long counter_self[MAXNPAPICNTRS]; #endif unsigned long long int calls; double percall_ms_self; double percall_ms_total; int index; int tid; int cluster; double *maxval; unsigned char is_max; char *name; char *filename; long long int sizeinfo; long long int min_sizeinfo, max_sizeinfo; double sizespeed, sizeavg; const equivalence_t *callpath; /* parent's tree down to callpath_depth */ int callpath_len; } drhook_prof_t; typedef struct drhook_memprof_t { double pc; long long int self; long long int children; long long int hwm, rss, stk, pag, leaked; unsigned long long int calls, alloc_count, free_count; int index; int tid; int cluster; long long int *maxval; unsigned char is_max; char *name; char *filename; const equivalence_t *callpath; /* parent's tree down to callpath_depth */ int callpath_len; } drhook_memprof_t; #define MAX_WATCH_FIRST_NBYTES 64 typedef struct drhook_watch_t { char *name; int tid; int active; int abort_if_changed; const char *ptr; int nbytes; int watch_first_nbytes; char first_nbytes[MAX_WATCH_FIRST_NBYTES]; unsigned int crc32; int printkey; int nvals; struct drhook_watch_t *next; } drhook_watch_t; /*** static (local) variables ***/ static pid_t pid = -1; static drhook_key_t **keydata = NULL; static drhook_calltree_t **calltree = NULL; static drhook_calltree_t **thiscall = NULL; static int signals_set = 0; static volatile sig_atomic_t signal_handler_called = 0; static volatile sig_atomic_t signal_handler_ignore_atexit = 0; static volatile sig_atomic_t unlimited_corefile_retcode = 9999; static volatile unsigned long long int saved_corefile_hardlimit = 0; static int allow_coredump = 0; /* -1 denotes ALL MPI-tasks, 1..NPES == myproc, 0 = coredump will not be enabled by DrHook at init */ static drhook_sig_t siglist[1+NSIG] = { 0 }; static char *a_out = NULL; static char *mon_out = NULL; static int mon_out_procs = -1; static double percent_limit = -10; /* Lowest percentage accepted into the printouts */ static drhook_key_t **keyself = NULL; /* pointers to itself (per thread) */ static double *overhead; /* Total Dr.Hook-overhead for every thread in either WALL or CPU secs */ static drhook_key_t **curkeyptr = NULL; /* pointers to current keyptr (per thread) */ static drhook_watch_t *watch = NULL; static drhook_watch_t *last_watch = NULL; static int watch_count = 0; /* No. of *active* watch points */ extern int ec_gettid(); // from ec_env.c static void set_ec_drhook_label(const char *hostname, long hlen) { long long int cycles = ec_get_cycles(); int tid = drhook_oml_get_thread_num(); // 1-based origin, not zero-based int j = tid - 1; int slen = sizeof(ec_drhook[j].s); pid_t unixtid = ec_gettid(); if (hlen >= 0 && hostname[hlen-1] == '\0') --hlen; // See ifsaux/parallel/run_fortran_omp_parallel.F90 : adds extra char(0), if called snprintf(ec_drhook[j].s,slen,"[EC_DRHOOK:%*s:%d:%d:%lld:%lld]", (int)hlen,hostname,myproc,tid, (long long int)pid, (long long int)unixtid); if (thread_cycles) thread_cycles[tid-1] = cycles; // Store OpenMP thread cycles at the beginning } #define SECS(x) ((int)(x)) #define NSECS(x) ((int)(1000000000 * ((x) - SECS(x)))) #ifdef _DRHOOK_TIMER_T_ static void set_killer_timer(const int *ntids, const int *target_omltid, const int *target_sig, const double *start_time, const char *p, long plen) { static volatile sig_atomic_t TimedKill = 0; if (ntids && target_omltid && target_sig && start_time && p) { int tid = drhook_oml_get_thread_num(); if (*target_omltid == -1 || *target_omltid == tid) { char *pfx = PREFIX(tid); timer_t timerid = { 0 }; struct itimerspec its = { 0 } ; struct sigevent sev = { 0 } ; sev.sigev_signo = *target_sig; #if defined(SIGEV_THREAD_ID) sev.sigev_notify = SIGEV_THREAD_ID | SIGEV_SIGNAL; /* sev.sigev_notify_thread_id = GETtid(); */ sev._sigev_un._tid = ec_gettid(); #elif defined(SIGEV_THREAD) sev.sigev_notify = SIGEV_THREAD | SIGEV_SIGNAL; #else sev.sigev_notify = SIGEV_SIGNAL; #endif sev.sigev_value.sival_ptr = &timerid; its.it_value.tv_sec = SECS(*start_time); its.it_value.tv_nsec = NSECS(*start_time); its.it_interval.tv_sec = 0; its.it_interval.tv_nsec = 0; #if defined(CLOCK_BOOTTIME) timer_create(CLOCK_BOOTTIME, &sev, &timerid); #else timer_create(CLOCK_MONOTONIC, &sev, &timerid); #endif /* timer_create(CLOCK_REALTIME, &sev, &timerid); */ timer_settime(timerid, 0, &its, NULL); cas_lock(&TimedKill); { fprintf(stderr, "%s %s [%s@%s:%d] Developer timer (%s) expires" " after %.3fs through signal#%d (ntids=%d)\n", pfx,TIMESTR(tid),FFL, p, *start_time, *target_sig, *ntids); } cas_unlock(&TimedKill); } /* if (target_omltid == -1 || target_omltid == tid) */ } } #endif #ifndef DR_HOOK_NCALLSTACK /* This compile definition serves as default which can still be overwritten using environment variable with same name */ #ifdef DR_HOOK_MULTI_PRECISION_HANDLES #define DR_HOOK_NCALLSTACK 64 /* > 0 : USE call stack approach : needed for single precision version */ #else #define DR_HOOK_NCALLSTACK 0 /* == 0 : do NOT use call stack approach : usually for double precision version */ #endif #endif static int cstklen = DR_HOOK_NCALLSTACK; #define HASHSIZE(n) ((unsigned int)1<<(n)) #define HASHMASK(n) (HASHSIZE(n)-1) #define NHASH 16 #define NHASHMAX 24 static int nhash = NHASH; static unsigned int hashsize = HASHSIZE(NHASH); static unsigned int hashmask = HASHMASK(NHASH); /*--- spin ---*/ static int nanospin(int secs, int nanosecs) { struct timespec req, rem; req.tv_sec = secs; req.tv_nsec = nanosecs; return nanosleep(&req, &rem); } static int spin(int secs) { return nanospin(secs, 0); } /*--- dump_file ---*/ static void dump_file(const char *pfx, int tid, int sig, int nsigs, const char filename[]) { /* Developer option: Will this spoil our ATP trace ... ? */ FILE *fp; char in[256]; char *tst = TIMESTR(tid); if (sig > 0 && nsigs >= 1) { fprintf(stderr, "%s %s [%s@%s:%d] Content of the file '%s', signal#%d, nsigs = %d\n", pfx,tst,FFL,filename,sig,nsigs); } else { fprintf(stderr, "%s %s [%s@%s:%d] Content of the file '%s'\n", pfx,tst,FFL,filename); } fp = fopen(filename,"r"); if (fp) { while (fgets(in,sizeof(in),fp) == in) { fprintf(stderr,"%s %s [%s@%s:%d] %s",pfx,tst,FFL,in); /* fprintf(stderr,"%s",in); */ } fclose(fp); } } /*--- dump_hugepages ---*/ // Forward declaration of subroutine in ec_meminfo.F90 extern void ec_meminfo_( const int* ku, const char* cdstring, const int* kcomm, const int* kbarr, const int* kiotask, const int* kcall, int cdstring_strlen ); static void dump_hugepages(int enforce, const char *pfx, int tid, int sig, int nsigs) { if (enforce || drhook_dump_hugepages) { if (enforce || tid == 1) { /* OML-thread id >= 1 */ static double next_scheduled = -1; double wt = WALLTIME(); if (enforce || wt > next_scheduled) { const int kcomm = -1; const int kbarr = 0; const int kiotask = 0; const int kcall = -1; const int ftnunitno = 0; /* stderr */ ec_meminfo_(&ftnunitno,pfx,&kcomm,&kbarr,&kiotask,&kcall,strlen(pfx)); if (drhook_dump_buddyinfo) { dump_file(pfx,tid,sig,nsigs,"/proc/buddyinfo"); } if (drhook_dump_meminfo) { dump_file(pfx,tid,sig,nsigs,"/proc/meminfo"); } wt = WALLTIME(); next_scheduled = wt + drhook_dump_hugepages_freq; } } } } /*--- set_default_handler ---*/ static int set_unlimited_corefile(unsigned long long int *hardlimit, int enforce); static int set_default_handler(int sig, int unlimited_corefile, int verbose) { int rc = -2; if (sig >= 1 && sig <= NSIG) { unsigned long long int hardlimit = 0; struct sigaction sa = { 0 }; sa.sa_handler = SIG_DFL; sigemptyset(&sa.sa_mask); /* sigfillset(&sa.sa_mask); -- if we wanted to block all (catchable) signals whilst in subsequent signal handler SIG_DFL sigaddset(&sa.sa_mask, some_signal_to_be_blocked); ... just in case */ sigaction(sig, &sa, NULL); if (unlimited_corefile) rc = set_unlimited_corefile(&hardlimit,0); /* unconditionally */ if (verbose) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); char buf[128] = ""; if (unlimited_corefile && rc == 0) snprintf(buf,sizeof(buf)," -- hardlimit for core file is now %llu (0x%llx)", hardlimit, hardlimit); fprintf(stderr, "%s %s [%s@%s:%d] " "Enabled default signal handler (SIG_DFL) for signal#%d%s\n", pfx,TIMESTR(tid),FFL, sig,buf); } } return rc; } /*--- malloc_drhook ---*/ void *malloc_drhook(size_t size) { size_t size1 = MAX(1,size); void *p = malloc(size1); if (!p) { fprintf(stderr, "***Error in malloc_drhook(): Unable to allocate space for %lld bytes\n", (long long int)size1); DRHOOK_ABORT(); } return p; } /*--- calloc_drhook ---*/ static void * calloc_drhook(size_t nmemb, size_t size) { size_t n = nmemb * size; void *p = malloc_drhook(n); memset(p,0,n); return p; } /*--- free_drhook ---*/ #define free_drhook(x) { if (x) { free(x); x = NULL; } } /*--- callstack ---*/ /* Note: For single precision calls -- small performance penalty */ typedef struct callstack_t { drhook_key_t **keyptr; unsigned int next; unsigned int maxdepth; } callstack_t; static callstack_t **cstk = NULL; static drhook_key_t *callstack(int tid, void *key, drhook_key_t *keyptr) { /* Single routine -- two usages: (1) Upon c_drhook_start_() we call: (void) callstack(tid, key, u.keyptr); - store keyptr into thread specific call stack - fill *key up to 4-bytes index stating the position in the aforementioned call stack (2) Upon c_drhook_end_() we call: u.keyptr = callstack(tid, (void *)key, NULL); - pass 4-byte index in - obtain keyptr from call stack - decrement call stack */ static const unsigned int inc = 64; unsigned int idx, *Index = key; callstack_t *c = cstk[tid-1]; if (keyptr) { if (!c) { cstk[tid-1] = c = calloc_drhook(1, sizeof(*c)); c->keyptr = (drhook_key_t **) calloc_drhook(cstklen, sizeof(drhook_key_t *)); c->next = 0; c->maxdepth = cstklen; } idx = (c->next)++; if (idx >= c->maxdepth) { drhook_key_t **kptr; unsigned int maxdepth = idx + inc; char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] " "Call stack index %u out of range [0,%u) : extending the range to [0,%u) for this thread\n", pfx,TIMESTR(tid),FFL, idx,c->maxdepth,maxdepth); kptr = (drhook_key_t **) calloc_drhook(maxdepth, sizeof(drhook_key_t *)); memcpy(kptr,c->keyptr,c->maxdepth * sizeof(drhook_key_t *)); free_drhook(c->keyptr); c->keyptr = kptr; c->maxdepth = maxdepth; } if (idx >= c->maxdepth) { char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] " "Call stack index %u still out of range [0,%u). Aborting ...\n", pfx,TIMESTR(tid),FFL, idx,c->maxdepth); DRHOOK_ABORT(); } c->keyptr[idx] = keyptr; *Index = idx; } else { idx = --(c->next); if (idx != *Index) { char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] " "Invalid index to call stack %u : out of range [0,%u). Expecting the exact value of %u\n", pfx,TIMESTR(tid),FFL, idx,c->maxdepth,*Index); DRHOOK_ABORT(); } keyptr = c->keyptr[idx]; } return keyptr; } /*--- strdup_drhook ---*/ static char * strdup_drhook(const char *s) { int n = strlen(s); char *p = malloc_drhook(n+1); memcpy(p,s,n); p[n] = 0; return p; } /*--- strdup2_drhook ---*/ static char * strdup2_drhook(const char *s, int s_len) { int n = s_len; char *p = malloc_drhook(n+1); memcpy(p,s,n); p[n] = 0; return p; } /*--- timestamp ---*/ static char * timestamp() { time_t tp; const int bufsize = 64; char *buf = malloc_drhook(bufsize+1); time(&tp); strftime(buf, bufsize, "%Y%m%d %H%M%S", localtime(&tp)); return buf; } /*--- TimeStr ---*/ static char * TimeStr(char *s, int slen) { if (s) { time_t tp; char buf[64]; time(&tp); strftime(buf, sizeof(buf), "%Y%m%d:%H%M%S", localtime(&tp)); snprintf(s,slen,"[%s:%.3f]",buf,WALLTIME()); } return s; } /* -- These 2 extern's are called primarily from LinuxTrbk() */ const char *drhook_TIMESTR(int tid) { static const char fixed[] = ""; if (tid <= 0) { tid = drhook_oml_get_thread_num(); } { char *s = TIMESTR(tid); return strlen(s) > 0 ? (const char *)s : fixed; } } const char *drhook_PREFIX(int tid) { static const char fixed[] = ""; if (tid <= 0) { tid = drhook_oml_get_thread_num(); } { char *s = PREFIX(tid); return strlen(s) > 0 ? (const char *)s : fixed; } } /*--- hashfunc ---*/ unsigned int hashfunc(const char *s, int s_len) { unsigned int hashval; if (opt_trim) { for (hashval = 0; s_len>0 ; s++, s_len--) { unsigned char c = islower(*s) ? toupper(*s) : *s; hashval = (hashval<<4)^(hashval>>28)^(c); } } else { for (hashval = s_len; s_len>0 ; s_len--) { hashval = (hashval<<4)^(hashval>>28)^(*s++); } } hashval = (hashval ^ (hashval>>10) ^ (hashval>>20)) & hashmask; return hashval; } /*--- callpath_hashfunc ---*/ unsigned int callpath_hashfunc(unsigned int inithash, /* from hashfunc() */ const equivalence_t *callpath, int callpath_len, unsigned int *fullhash) { unsigned int hashval; for (hashval = inithash; callpath_len>0 ; callpath++, callpath_len--) { hashval = (hashval<<4)^(hashval>>28)^(callpath->ull); } if (fullhash) *fullhash = hashval; hashval = (hashval ^ (hashval>>10) ^ (hashval>>20)) & hashmask; return hashval; } /*--- insert_calltree ---*/ static void insert_calltree(int tid, drhook_key_t *keyptr) { if (tid >= 1 && tid <= numthreads) { drhook_calltree_t *treeptr = thiscall[tid-1]; while (treeptr->active) { if (!treeptr->next) { treeptr->next = calloc_drhook(1,sizeof(drhook_calltree_t)); treeptr->next->prev = treeptr; } treeptr = treeptr->next; } treeptr->keyptr = keyptr; treeptr->active = 1; thiscall[tid-1] = treeptr; } } /*--- remove_calltree ---*/ static void remove_calltree(int tid, drhook_key_t *keyptr, const double *delta_wall, const double *delta_cpu, const long long int *delta_cycles, long_long * delta_counters ) { if (tid >= 1 && tid <= numthreads) { drhook_calltree_t *treeptr = thiscall[tid-1]; if (treeptr->active && treeptr->keyptr == keyptr) { treeptr->active = 0; if (treeptr->prev) { drhook_key_t *parent_keyptr = treeptr->prev->keyptr; if (parent_keyptr) { /* extra security */ #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) drhook_papi_add(NULL, parent_keyptr->delta_counters_child, delta_counters ); #endif if (opt_walltime) { parent_keyptr->delta_wall_child += (*delta_wall); } if (opt_cputime) { parent_keyptr->delta_cpu_child += (*delta_cpu); } if (opt_cycles) { parent_keyptr->delta_cycles_child += (*delta_cycles); } if (opt_memprof) { /* const long long int size = 0; c_drhook_memcounter_(&tid, &size, NULL); fprintf(stderr, ">parent(%.*s)->mem_child = %lld ; this(%.*s)->alldelta = %lld, mem_child = %lld\n", parent_keyptr->name_len, parent_keyptr->name, parent_keyptr->mem_child, keyptr->name_len, keyptr->name, keyptr->maxmem_alldelta, keyptr->mem_child); */ parent_keyptr->mem_child = MAX(parent_keyptr->mem_child, keyptr->maxmem_alldelta); /* fprintf(stderr, "mem_child = %lld ; this(%.*s)->alldelta = %lld, mem_child = %lld\n", parent_keyptr->name_len, parent_keyptr->name, parent_keyptr->mem_child, keyptr->name_len, keyptr->name, keyptr->maxmem_alldelta, keyptr->mem_child); */ } } /* if (parent_keyptr) */ thiscall[tid-1] = treeptr->prev; } else { thiscall[tid-1] = calltree[tid-1]; } curkeyptr[tid-1] = thiscall[tid-1]->keyptr; } else { curkeyptr[tid-1] = NULL; } /* if (treeptr->active && treeptr->keyptr == keyptr) else ... */ } } /*--- memstat ---*/ static long long int slave_stacksize() { char *env_omp = getenv("OMP_STACKSIZE"); long long int stacksize = env_omp ? atoll(env_omp) : 0; if (env_omp) { if (strchr(env_omp,'G')) stacksize *= (long long int)1073741824; /* hence, in GiB */ else if (strchr(env_omp,'M')) stacksize *= (long long int)1048576; /* hence, in MiB */ else if (strchr(env_omp,'K')) stacksize *= (long long int)1024; /* hence, in KiB */ } if (stacksize < 0) stacksize = 0; return stacksize; } static void memstat(drhook_key_t *keyptr, const int *thread_id, int in_getkey) { if (any_memstat && keyptr) { if (opt_gethwm) keyptr->hwm = gethwm_(); if (opt_getrss) { keyptr->maxrss = getrss_(); keyptr->rssnow = getcurheap_thread_(thread_id); } if (opt_getstk) { long long int stk = getstk_(); keyptr->stack = stk; keyptr->maxstack = MAX(keyptr->maxstack,stk); } if (opt_getpag) keyptr->paging = getpag_(); if (opt_memprof) { keyptr->mem_seenmax = getmaxcurheap_thread_(thread_id); if (in_getkey) { /* Upon enter of a Dr.Hook'ed routine */ /* A note for "keyptr->mem_curdelta": 1) do not reset to 0 2) initially calloc'ed to 0 while initializing the keydata[] ~ alias keyptr 3) remember the previous value --> catches memory leaks, too !! */ /* keyptr->mem_curdelta = 0; */ /* Nearly the same holds for "keyptr->mem_child"; we need to capture the maximum/hwm for child */ /* keyptr->mem_child = 0; */ keyptr->paging_in = keyptr->paging; } else { /* Upon exit of a Dr.Hook'ed routine */ long long int alldelta = keyptr->mem_curdelta + keyptr->mem_child; if (alldelta > keyptr->maxmem_alldelta) keyptr->maxmem_alldelta = alldelta; if (keyptr->paging - keyptr->paging_in > keyptr->mem_maxpagdelta) keyptr->mem_maxpagdelta = keyptr->paging - keyptr->paging_in; } if (keyptr->hwm > keyptr->mem_maxhwm) keyptr->mem_maxhwm = keyptr->hwm; if (keyptr->maxrss > keyptr->mem_maxrss) keyptr->mem_maxrss = keyptr->maxrss; if (keyptr->maxstack > keyptr->mem_maxstk) keyptr->mem_maxstk = keyptr->maxstack; } } } /*--- flptrap ---*/ /* ----------------------------------------------------------------------- If we are trapping Floating-Point Error, then set the processor in SYNC modes and enable TRP_INVALID, TRP_DIV_BY_ZERO and TRP_OVERFLOW. ----------------------------------------------------------------------- */ #if (defined(__GNUC__) || defined(__PGI)) && !defined(NO_TRAPFPE) static void flptrap(int sig, int silent) { if (sig == SIGFPE) { /* Adapted from www.twinkle.ws/arnaud/CompilerTricks.html#Glibc_FP */ trapfpe(silent); /* No need for pgf90's -Ktrap=fp now ? */ } } #else static void flptrap(int sig, int silent) { return; /* A dummy */ } #endif static void signal_gencore(int sig SIG_EXTRA_ARGS); static void signal_harakiri(int sig SIG_EXTRA_ARGS); static void signal_drhook(int sig SIG_EXTRA_ARGS); static void trapfpe_treatment(int sig, int silent); /*--- catch_signals ---*/ #define CATCHSIG(x) {\ drhook_sig_t *sl = &siglist[x];\ if (sl->active == 0) {\ drhook_sigfunc_t u;\ u.func3args = signal_drhook;\ sl->active = 1;\ sigemptyset(&sl->new.sa_mask);\ sl->new.sa_handler = u.func1args;\ sl->new.sa_flags = SA_SIGINFO;\ sigaction(x,&sl->new,&sl->old);\ trapfpe_treatment(x,silent); \ if (!silent && myproc == 1) {\ int tid = drhook_oml_get_thread_num(); \ char *pfx = PREFIX(tid); \ fprintf(stderr,\ "%s %s [%s@%s:%d] DR_HOOK also catches signal#%d : New handler '%s' installed at %p (next at %p)\n", \ pfx,TIMESTR(tid),FFL, \ x, "signal_drhook", (void *) sl->new.sa_handler, (void *)sl->old.sa_handler); \ }\ }\ } static void catch_signals(int silent) { char *env = getenv("DR_HOOK_CATCH_SIGNALS"); if (!silent && myproc == 1) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK_CATCH_SIGNALS=%s\n", pfx,TIMESTR(tid),FFL, env ? env : ""); } if (env) { const char delim[] = ", \t/"; char *p, *s = strdup_drhook(env); p = strtok(s,delim); while (p) { int sig = atoi(p); if (sig >= 1 && sig <= NSIG) { CATCHSIG(sig); } else if (sig == -1) { /* Makes ALL (catchable) signals available to DR_HOOK */ int j; for (j=1; j<=NSIG; j++) { CATCHSIG(j); } /* for (j=1; j<=NSIG; j++) */ break; } p = strtok(NULL,delim); } free_drhook(s); } } /*--- trapfpe_treatment ---*/ static void trapfpe_treatment(int sig, int silent) { if (sig == SIGFPE) { #if (defined(__GNUC__) || defined(__PGI)) && !defined(NO_TRAPFPE) int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); if (drhook_trapfpe) { if (!silent && myproc == 1) { fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK enables SIGFPE-related floating point trapping since DR_HOOK_TRAPFPE=%d\n", pfx,TIMESTR(tid),FFL, drhook_trapfpe); } flptrap(sig,silent); /* Has FLP-trapping on, regardless */ } else { if (!silent && myproc == 1) { fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK turns SIGFPE-related floating point trapping off since DR_HOOK_TRAPFPE=%d\n", pfx,TIMESTR(tid),FFL, drhook_trapfpe); } untrapfpe(silent); /* Turns off a possible -Ktrap=fp from pgf90 */ } #endif } } /* Fortran callable : calls trapfpe() for slave threads if drhook_trapfpe indicated so Called from DR_HOOK_UTIL_MULTI after DR_HOOK_UTIL (master thread) has been called Matters only for slave threads If *silent = 0, then more verbose output */ void trapfpe_slave_threads_(const int *silent) { int tid = drhook_oml_get_thread_num(); if (tid > 1) { // slave threads if (drhook_trapfpe_master_init) trapfpe_treatment(SIGFPE, *silent); } } void trapfpe_slave_threads(const int *silent) { trapfpe_slave_threads_(silent); } /*--- restore_default_signals ---*/ static void restore_default_signals(int silent) { char *env = getenv("DR_HOOK_RESTORE_DEFAULT_SIGNALS"); if (!silent && myproc == 1) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK_RESTORE_DEFAULT_SIGNALS=%s\n", pfx,TIMESTR(tid),FFL, env ? env : ""); } if (env) { int unlim_core = 0; // we do not want to set the core limit here at all const char delim[] = ", \t/"; char *p, *s = strdup_drhook(env); p = strtok(s,delim); while (p) { int sig = atoi(p); if (sig >= 1 && sig <= NSIG) { drhook_sig_t *sl = &siglist[sig]; if (sl->active == 0) { /* Not touched yet by ignore_signals() */ set_default_handler(sig,unlim_core,(!silent && myproc == 1)); unlim_core = 0; if (sig == SIGFPE) trapfpe_treatment(sig, (!silent && myproc == 1)); sl->active = -2; } } else if (sig == -1) { /* Restore default signals for all available/catchable to DR_HOOK */ int j; for (j=1; j<=NSIG; j++) { drhook_sig_t *sl = &siglist[j]; if (sl->active == 0) { /* Not touched yet by ignore_signals() */ set_default_handler(j,unlim_core,(!silent && myproc == 1)); unlim_core = 0; if (j == SIGFPE) trapfpe_treatment(j, (!silent && myproc == 1)); sl->active = -2; } } /* for (j=1; j<=NSIG; j++) */ break; } p = strtok(NULL,delim); } free_drhook(s); } } /*--- ignore_signals ---*/ static void ignore_one_signal(int sig, int silent) { if (sig >= 1 && sig <= NSIG) { drhook_sig_t *sl = &siglist[sig]; sl->active = -1; if (!silent && myproc == 1) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK ignores signal#%d (%s)\n", pfx,TIMESTR(tid),FFL, sig,strsignal(sig)); } } } static void ignore_signals(int silent) { char *env = getenv("DR_HOOK_IGNORE_SIGNALS"); if (!silent && myproc == 1) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] DR_HOOK_IGNORE_SIGNALS=%s\n", pfx,TIMESTR(tid),FFL, env ? env : ""); } if (env) { const char delim[] = ", \t/"; char *p, *s = strdup_drhook(env); p = strtok(s,delim); while (p) { int sig = atoi(p); if( sig == -1 ) { /* Switches off ALL signals from DR_HOOK */ int j; for (j=1; j<=NSIG; j++) { ignore_one_signal(j,silent); } break; } else { ignore_one_signal(sig,silent); } p = strtok(NULL,delim); } free_drhook(s); } } /*--- signal_drhook ---*/ #define SETSIG5(x,ignore_flag,handler_name,preserve_old,xstr) { \ drhook_sig_t *sl = &siglist[x]; \ if (sl->active == 0) { \ drhook_sigfunc_t u; \ u.func3args = handler_name; \ sl->active = 1; \ strcpy(sl->name,xstr); \ sigemptyset(&sl->new.sa_mask); \ sl->new.sa_handler = u.func1args; \ sl->new.sa_flags = SA_SIGINFO; \ sigaction(x,&sl->new,preserve_old ? &sl->old : NULL); \ sl->ignore_atexit = ignore_flag; \ trapfpe_treatment(x,silent); \ if (!silent && myproc == 1) { \ int tid = drhook_oml_get_thread_num(); \ char *pfx = PREFIX(tid); \ const char fmt[] = "%s %s [%s@%s:%d] New signal handler '%s' for signal#%d (%s) at %p (next at %p)\n"; \ fprintf(stderr,fmt, \ pfx,TIMESTR(tid),FFL, \ #handler_name, \ x, sl->name, \ (void*) sl->new.sa_handler, \ preserve_old ? (void*) sl->old.sa_handler : NULL); \ } \ } \ } #define SETSIG(x,ignore_flag) SETSIG5(x,ignore_flag,signal_drhook,1,#x) #define JSETSIG(x,ignore_flag) { \ drhook_sig_t *sl = &siglist[x]; \ drhook_sigfunc_t u; \ /* fprintf(stderr,"JSETSIG: sl->active = %d\n",sl->active); */ \ u.func3args = signal_harakiri; \ sl->active = 1; \ strcpy(sl->name,#x); \ sigemptyset(&sl->new.sa_mask); \ sl->new.sa_handler = u.func1args; \ sl->new.sa_flags = SA_SIGINFO; \ sigaction(x,&sl->new,&sl->old); \ sl->ignore_atexit = ignore_flag; \ trapfpe_treatment(x,0); \ } #define DRH_STRUCT_RLIMIT struct rlimit #define DRH_GETRLIMIT getrlimit #define DRH_SETRLIMIT setrlimit static int set_unlimited_corefile(unsigned long long int *hardlimit, int enforce) { /* Make sure we *only* set soft-limit (not hard-limit) to 0 in our scripts i.e. : $ ulimit -S -c 0 but *not* $ ulimit -c 0 See man ksh or man bash for more */ int rc = -1; if (enforce || unlimited_corefile_retcode == 9999) { /* Done only once -- or if enforced*/ DRH_STRUCT_RLIMIT r; if (DRH_GETRLIMIT(RLIMIT_CORE, &r) == 0) { r.rlim_cur = r.rlim_max; if (DRH_SETRLIMIT(RLIMIT_CORE, &r) == 0) { saved_corefile_hardlimit = r.rlim_cur; rc = 0; } } unlimited_corefile_retcode = rc; } if (hardlimit) *hardlimit = saved_corefile_hardlimit; rc = unlimited_corefile_retcode; return rc; } static void signal_gencore(int sig SIG_EXTRA_ARGS) { if (opt_gencore > 0) { opt_gencore = 0; /* A tiny chance for a race condition between threads */ if (sig == opt_gencore_signal && sig >= 1 && sig <= NSIG) { signal(sig, SIG_IGN); signal(SIGABRT, SIG_DFL); { /* Enable unlimited cores (up to hard-limit) and call abort() --> generates core dump */ if (set_unlimited_corefile(NULL,1) == 0) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); fprintf(stderr, "%s %s [%s@%s:%d] Received signal#%d and now calling abort() ...\n", pfx,TIMESTR(tid),FFL, sig); LinuxTraceBack(pfx,TIMESTR(tid),NULL); abort(); /* Dump core, too */ } } /* Should never end up here */ _exit(128+ABS(sig)); } /* if (sig == opt_gencore_signal && sig >= 1 && sig <= NSIG) */ } } static char *safe_llitoa(long long int i, char b[], int blen) { char const digit[] = "0123456789"; char *p = b; long long int shifter; if (i < 0) { *p++ = '-'; i *= -1; } shifter = i; do { /* Move to where representation ends */ ++p; shifter = shifter/10; } while (shifter); *p = '\0'; do{ /* Move back, inserting digits as u go */ *--p = digit[i%10]; i = i/10; } while (i); return b; } static void signal_harakiri(int sig SIG_EXTRA_ARGS) { /* A signal handler that will force to exit the current thread immediately for sure */ /* The following output should be malloc-free */ time_t tp; int fd = fileno(stderr); int tid = drhook_oml_get_thread_num(); int nsigs = TIDNSIGS(tid); char *pfx = PREFIX(tid); char buf[128]; char s[1024]; strcpy(s,pfx); /* [%s@%s:%d] for FFL below */ strcat(s," ["); strcat(s,__FUNCTION__); strcat(s,"@"); strcat(s,_DRHOOK_FILE_); strcat(s,":"); strcat(s,safe_llitoa(__LINE__,buf,sizeof(buf))); strcat(s,"] [epoch="); time(&tp); strcat(s,safe_llitoa(tp,buf,sizeof(buf))); strcat(s,"] Terminating process to avoid hangs due to signal#"); strcat(s,safe_llitoa(sig,buf,sizeof(buf))); strcat(s," by raising signal SIGKILL = "); strcat(s,safe_llitoa(SIGKILL,buf,sizeof(buf))); strcat(s,", nsigs = "); strcat(s,safe_llitoa(nsigs,buf,sizeof(buf))); strcat(s,"\n"); (void) write(fd,s,strlen(s)); #if 0 batch_kill_(); #endif raise(SIGKILL); /* Use raise, not RAISE here */ _exit(128+ABS(sig)); /* Should never reach here, bu' in case it does, then ... */ } static void signal_drhook(int sig SIG_EXTRA_ARGS) { volatile int nfirst = drhook_use_lockfile ? 0 : 1; int nsigs = 0; int trace_size = 0; int tid; pid_t unixtid; char *pfx; void *trace[GNUC_BTRACE]; // Let only one ("fastest") thread per task to this error processing static volatile sig_atomic_t been_here_already = 0; static volatile sig_atomic_t thing = 0; if (sig < 1 || sig > NSIG) return; // .. since have seen this, too :-( if (been_here_already++ > 0) return; // avoid calling more than once ... since it leads more often than not into troubles cas_lock(&thing); unixtid = ec_gettid(); tid = drhook_oml_get_thread_num(); pfx = PREFIX(tid); if (signals_set && sig >= 1 && sig <= NSIG) { drhook_sig_t *sl = &siglist[sig]; sigset_t newmask, oldmask; /* A tiny chance for a race condition between threads */ // Using compare-and-swap -stuff from the include cas.h (also in ecProf) /* Signal catching */ { nsigs = (++signal_handler_called); if (sl->ignore_atexit) signal_handler_ignore_atexit++; } if (ec_drhook && tid >= 1 && tid <= numthreads) ec_drhook[tid-1].nsigs = nsigs; /* Store for possible signal_harakiri() */ /*------------------------------------------------------------ Strategy: - drhook intercepts most interrupts. - 1st interupt will - call alarm(10) to try to make sure 2nd interrupt received - try to call tracebacks and exit (which includes atexits) - 2nd (and subsequent) interupts will - spin for 20 sec (to give 1st interrupt time to complete tracebacks) - and then call _exit (bypassing atexit) ------------------------------------------------------------*/ /* if (sig != SIGTERM) signal(SIGTERM, SIG_DFL); */ /* Let the default SIGTERM to occur */ // max_threads = drhook_oml_get_max_threads(); if (nsigs == 1) { /*---- First call to signal handler: call alarm(drhook_harakiri_timeout), tracebacks, exit ------*/ if (!nfirst) { // Correct coding : one and only one task obtains exclusive creation mask -- others fire blanks! int fd = open(drhook_lockfile,O_CREAT|O_WRONLY|O_TRUNC|O_EXCL,S_IRUSR|S_IWUSR); if (fd >= 0) { size_t count = sizeof(myproc); ssize_t sz = write(fd,&myproc,count); // Now we know which MPL-task got the lock (use octal-dump "od" command) close(fd); nfirst = 1; } } if (nfirst) { /* Enjoy some output (only from the first guy that came in) */ fprintf(stderr, "[EC_DRHOOK:hostname:myproc:omltid:pid:unixtid] [YYYYMMDD:HHMMSS:walltime] [function@file:lineno]\n"); long long int hwm = gethwm_(); long long int rss = getmaxrss_(); long long int maxstack = getmaxstk_(); long long int vmpeak = getvmpeak_(); long long int pag = getpag_(); rss /= 1048576; hwm /= 1048576; maxstack /= 1048576; vmpeak /= 1048576; fprintf(stderr, "%s %s [%s@%s:%d] Received signal#%d (%s) :: %lldMB (heap)," " %lldMB (maxrss), %lldMB (maxstack), %lldMB (vmpeak), %lld (paging), nsigs = %d\n", pfx,TIMESTR(tid),FFL, sig, sl->name, hwm, rss, maxstack, vmpeak, pag, nsigs); if (allow_coredump) { unsigned long long int hardlimit = 0; int rc = set_unlimited_corefile(&hardlimit,1); if (rc == 0) { fprintf(stderr, "%s %s [%s@%s:%d] Hardlimit for core file is now %llu (0x%llx)\n", pfx,TIMESTR(tid),FFL,hardlimit,hardlimit); } } #if 1 fprintf(stderr, "%s %s [%s@%s:%d] Also activating Harakiri-alarm (SIGALRM=%d) to expire after %ds elapsed to prevent hangs, nsigs = %d\n", pfx,TIMESTR(tid),FFL, SIGALRM,drhook_harakiri_timeout,nsigs); #endif JSETSIG(SIGALRM,1); /* This will now set another signal handler than signal_drhook */ alarm(drhook_harakiri_timeout); trace_size = backtrace(trace, GNUC_BTRACE); } #if defined(SA_SIGINFO) && SA_SIGINFO > 0 if (sigcode) { const char *s = NULL; void *addr = sigcode->si_addr; void *bt = addr; ucontext_t *uc = (ucontext_t *)sigcontextptr; #ifdef __powerpc64__ bt = uc ? (void *) uc->uc_mcontext.regs->nip : NULL; // Trick from PAPI_overflow() #elif defined(__x86_64__) && defined(REG_RIP) // gcc specific bt = uc ? (void *) uc->uc_mcontext.gregs[REG_RIP] : NULL; // RIP: x86_64 specific ; only available in 64-bit mode */ #elif defined(__i386__) && defined(REG_EIP) // gcc specific bt = uc ? (void *) uc->uc_mcontext.gregs[REG_EIP] : NULL; // EIP: x86 specific ; only available in 32-bit mode */ #endif if (!addr) addr = bt; if (sig == SIGFPE) { switch (sigcode->si_code) { case FPE_INTDIV: s = "integer divide by zero"; break; case FPE_INTOVF: s = "integer overflow"; break; case FPE_FLTDIV: s = "floating-point divide by zero"; break; case FPE_FLTOVF: s = "floating-point overflow"; break; case FPE_FLTUND: s = "floating-point underflow"; break; case FPE_FLTRES: s = "floating-point inexact result"; break; case FPE_FLTINV: s = "floating-point invalid operation"; break; case FPE_FLTSUB: s = "subscript out of range"; break; default: s = "unrecognized si_code for SIGFPE"; break; } } else if (sig == SIGILL) { switch (sigcode->si_code) { case ILL_ILLOPC: s = "illegal opcode"; break; case ILL_ILLOPN: s = "illegal operand"; break; case ILL_ILLADR: s = "illegal addressing mode"; break; case ILL_ILLTRP: s = "illegal trap"; break; case ILL_PRVOPC: s = "privileged opcode"; break; case ILL_PRVREG: s = "privileged register"; break; case ILL_COPROC: s = "coprocessor error"; break; case ILL_BADSTK: s = "internal stack error"; break; default: s = "unrecognized si_code for SIGILL"; break; } } else if (sig == SIGSEGV) { switch (sigcode->si_code) { case SEGV_MAPERR: s = "address not mapped to object"; break; case SEGV_ACCERR: s = "invalid permissions for mapped object"; break; default: s = "unrecognized si_code for SIGSEGV"; break; } } else if (sig == SIGBUS) { switch (sigcode->si_code) { case BUS_ADRALN: s = "invalid address alignment"; break; case BUS_ADRERR: s = "nonexistent physical address"; break; case BUS_OBJERR: s = "object-specific hardware error"; break; default: s = "unrecognized si_code for SIGBUS"; break; } } else { s = "unrecognized si_code"; } if (s && nfirst) { int dlworks = 0; Dl_info dlinfo; if (dladdr(bt,&dlinfo) == 0) { dlinfo.dli_fname = NULL; dlinfo.dli_sname = NULL; dlinfo.dli_fbase = 0; } else dlworks = 1; if (sig == SIGFPE) { extern int fegetexcept(void); int excepts = fegetexcept(); fprintf(stderr, "%s %s [%s@%s:%d] Signal#%d was caused by %s [memaddr=%p] [excepts=0x%x [%d]] : %p at %s(%s), nsigs = %d\n", pfx,TIMESTR(tid),FFL, sig, s, addr, excepts, excepts, bt, dlinfo.dli_fname ? dlinfo.dli_fname : "", dlinfo.dli_sname ? dlinfo.dli_sname : "", nsigs); } else { fprintf(stderr, "%s %s [%s@%s:%d] Signal#%d was caused by %s [memaddr=%p] : %p at %s(%s), nsigs = %d\n", pfx,TIMESTR(tid),FFL, sig, s, addr, bt, dlinfo.dli_fname ? dlinfo.dli_fname : "", dlinfo.dli_sname ? dlinfo.dli_sname : "", nsigs); } if (dlworks && trace_size > 0) { int ndigits = 1 + (int)log10(trace_size); int jt; for (jt = 0; jt < trace_size; ++jt) { void *pbt = trace[jt]; if (dladdr(pbt,&dlinfo) == 0) { dlinfo.dli_fname = NULL; dlinfo.dli_sname = NULL; dlinfo.dli_fbase = 0; } fprintf(stderr, "%s %s [%s@%s:%d] : [%*.*d]: %s %s %p %p # addr2line\n", pfx,TIMESTR(tid),FFL, ndigits, ndigits, jt, dlinfo.dli_sname ? dlinfo.dli_sname : "", dlinfo.dli_fname ? dlinfo.dli_fname : "", dlinfo.dli_fbase, pbt); } } } } #endif } if (nsigs > 1 || !nfirst) { /*----- 2nd (and subsequent) calls to signal handler: spin harakiri-timeout + 60 sec, _exit ---------*/ int offset = 60; int secs = drhook_harakiri_timeout+offset; if (!drhook_use_lockfile) { /* Less output if lockfile was used ... */ fprintf(stderr, "%s %s [%s@%s:%d] Calling signal_harakiri upon receipt of signal#%d" " after %ds spin, nsigs = %d, nfirst = %d\n", pfx,TIMESTR(tid),FFL, sig,secs,nsigs,nfirst); } spin(secs); signal_harakiri(sig SIG_PASS_EXTRA_ARGS); } /* All below this point should be nsigs == 1 i.e. the first threat arriving signal_drhook() */ /* sigfillset(&newmask); -- dead code since sigprocmask() was not called */ /* sigemptyset(&newmask); sigaddset(&newmask, sig); */ /* Start critical region (we don't want any signals to interfere while doing this) */ /* sigprocmask(SIG_BLOCK, &newmask, &oldmask); */ if (nsigs == 1 && nfirst) { /* Print Dr.Hook traceback */ const int ftnunitno = 0; /* stderr */ const int print_option = 2; /* calling tree */ int level = 0; fprintf(stderr, "%s %s [%s@%s:%d] Starting DrHook backtrace for signal#%d, nsigs = %d\n", pfx,TIMESTR(tid),FFL, sig,nsigs); dump_hugepages(0,pfx,tid,sig,nsigs); /* We don't wanna enforce anymore -- this the first arg == 0 now */ if (drhook_dump_smaps) { char filename[64]; snprintf(filename,sizeof(filename),"/proc/%ld/smaps",(long)unixtid); dump_file(pfx,tid,sig,nsigs,filename); } if (drhook_dump_maps) { char filename[64]; snprintf(filename,sizeof(filename),"/proc/%ld/maps",(long)unixtid); dump_file(pfx,tid,sig,nsigs,filename); } if (drhook_dump_buddyinfo) { dump_file(pfx,tid,sig,nsigs,"/proc/buddyinfo"); } if (drhook_dump_meminfo) { dump_file(pfx,tid,sig,nsigs,"/proc/meminfo"); } c_drhook_print_(&ftnunitno, &tid, &print_option, &level); /* To make it less likely that another thread generates a signal while we are doing a traceback lets wait a while (seems to fix problems of the traceback terminating abnormally. Probably a better way of doing this involving holding off signals but sigprocmask is not safe in multithreaded code - P Towers Dec 10 2012 This was originally an issue with the Intel compiler but may be of benefit for other compilers. Cannot see it doing harm - P Towers Aug 29 2013 */ // spin(MIN(5,tid)); // obsolete: only one thread (and task) ever gets here ! if (sig != SIGABRT && sig != SIGTERM) { #if (defined(LINUX) || defined(__APPLE__)) LinuxTraceBack(pfx,TIMESTR(tid),NULL); #endif #ifdef __INTEL_COMPILER intel_trbk_(); /* from ../utilities/gentrbk.F90 */ #endif } fprintf(stderr, "%s %s [%s@%s:%d] DrHook backtrace done for signal#%d, nsigs = %d\n", pfx,TIMESTR(tid),FFL,sig,nsigs); } /* sigprocmask(SIG_SETMASK, &oldmask, 0); */ /* End critical region : the original signal state restored */ { int restored = 0, tdiff; time_t t1, t2; drhook_sigfunc_t u; u.func3args = signal_drhook; if (opt_propagate_signals && sl->old.sa_handler != SIG_DFL && sl->old.sa_handler != SIG_IGN && sl->old.sa_handler != u.func1args) { u.func1args = sl->old.sa_handler; if (atp_enabled) { /* Restore the default, core-file creating action to these "ATP" recognized signals */ switch (sig) { case SIGTERM: if (atp_ignore_sigterm) break; /* SIGSEGV not reset to SIG_DFL as ATP now ignores SIGTERM */ FIAT_PP_FALLTHROUGH; /* Fall thru (see man atp on Cray) */ case SIGINT: /* Also, see ifssig.c : used as a RESTART signal, confusingly enough */ case SIGFPE: case SIGILL: case SIGTRAP: case SIGABRT: case SIGBUS: case SIGSEGV: case SIGSYS: case SIGXCPU: #if defined(SIGXFSZ) case SIGXFSZ: #endif fprintf(stderr, "%s %s [%s@%s:%d] Resetting SIGSEGV (%d) to " "default signal handler (SIG_DFL) before calling ATP for signal#%d, nsigs = %d\n", pfx,TIMESTR(tid),FFL, SIGSEGV,sig,nsigs); set_default_handler(SIGSEGV,1,1); restored = 1; break; default: break; } } fprintf(stderr, "%s %s [%s@%s:%d] Calling previous signal handler at %p for signal#%d, nsigs = %d\n", pfx,TIMESTR(tid),FFL, (void*) u.func1args,sig,nsigs); time(&t1); u.func3args(sig SIG_PASS_EXTRA_ARGS); /* This could now be the ATP */ time(&t2); tdiff = (t2 - t1); fprintf(stderr, "%s %s [%s@%s:%d] Returned from previous signal handler" " (at %p, signal#%d, time taken = %ds), nsigs = %d\n", pfx,TIMESTR(tid),FFL, (void*) u.func1args,sig,tdiff,nsigs); if (atp_enabled && restored && atp_max_cores > 0) { /* Assuming it was indeed ATP, then lets spin a bit to allow other cores be dumped */ int secs = MIN(drhook_harakiri_timeout,atp_max_analysis_time); int grace = 60; secs = 60 + MIN(tdiff * (atp_max_cores-1),secs); if (secs > 0) { fprintf(stderr, "%s %s [%s@%s:%d] Before aborting (signal#%d) spin %ds (incl. grace %ds)" " to give ATP time to write all #%d core file(s), nsigs = %d\n", pfx,TIMESTR(tid),FFL, sig,secs,grace,atp_max_cores,nsigs); spin(secs); } } if (sig != SIGABRT && sig != SIGTERM) { if (atp_enabled && atp_max_cores > 0) { fprintf(stderr, "%s %s [%s@%s:%d] DrHook calls abort() and attempts to dump core (signal#%d), nsigs = %d\n", pfx,TIMESTR(tid),FFL, sig,nsigs); set_default_handler(SIGABRT,1,1); abort(); } } /* Now proceed to definitive _exit() */ } else { fprintf(stderr, "%s %s [%s@%s:%d] Not configured (DR_HOOK_PROPAGATE_SIGNALS=%d) or " "can't call previous signal handler (for signal#%d) in the chain at %p, nsigs = %d\n", pfx,TIMESTR(tid),FFL, opt_propagate_signals,sig, (void*) sl->old.sa_handler,nsigs); } } } { int errcode = 128 + ABS(sig); /* Make sure that the process/thread really exits now -- immediately !! */ fprintf(stderr, "%s %s [%s@%s:%d] Error _exit(%d) upon receipt of signal#%d, nsigs = %d\n", pfx,TIMESTR(tid),FFL, errcode,sig,nsigs); _exit(errcode); } cas_unlock(&thing); } /*--- signal_drhook_init ---*/ static void signal_drhook_init(int enforce) { char *env = getenv("DR_HOOK_SILENT"); int silent = env ? atoi(env) : 0; int j; int mpi_init; c_dr_hook_procinfo(&myproc, &nproc, &mpi_init); /* Signals may not yet been set, since MPI not initialized Enforce parameter for setting signals regardless of MPI state */ if (!enforce && !mpi_init) return; if (signals_set) return; /* Extra safety */ /* To present sumpini.F90 (f.ex.) initializing DrHook-signals in case of DR_HOOK was turned off (=0), then set also export DR_HOOK_INIT_SIGNALS=0 */ env = getenv("DR_HOOK_INIT_SIGNALS"); if (env && *env == '0') { signals_set = 2; /* Pretend they are set */ return; /* Never initialize signals via DrHook (dangerous, but sometimes necessary) */ } if (!ec_drhook) { long hlen; char hostname[EC_HOST_NAME_MAX]; char *pdot; int ntids = drhook_oml_get_max_threads(); numthreads = ntids; thread_cycles = calloc_drhook(ntids, sizeof(*thread_cycles)); ec_drhook = calloc_drhook(ntids, sizeof(*ec_drhook)); timestr_len = sizeof(ec_drhook[0].timestr); if (gethostname(hostname,sizeof(hostname)) != 0) strcpy(hostname,"unknown"); pdot = strchr(hostname,'.'); if (pdot) { *pdot = '\0'; // cut short from "." char e.g. hostname.fmi.fi becomes just "hostname" } else { char *pblank = strchr(hostname,' '); if (pblank) *pblank = '\0'; } hlen = strlen(hostname); { extern void drhook_run_omp_parallel_ipfstr_(const int *, void (*func)(const char *, long), const char *, /*hidden*/ long); drhook_run_omp_parallel_ipfstr_(&ntids,set_ec_drhook_label,hostname,hlen); } } process_options(); for (j=1; j<=NSIG; j++) { /* Initialize */ drhook_sig_t *sl = &siglist[j]; sprintf(sl->name, "DR_HOOK_SIG#%d", j); sl->active = 0; sl->ignore_atexit = 0; } ignore_signals(silent); /* These signals will not be handled by DR_HOOK */ restore_default_signals(silent); /* These signals will be restored with SIG_DFL status (regardless if to-be-caught with DrHook or ATP or anyhing else) */ SETSIG(SIGABRT,0); /* Good to be first */ SETSIG(SIGBUS,0); SETSIG(SIGSEGV,0); #if defined(SIGEMT) SETSIG(SIGEMT,0); #endif #if defined(SIGSTKFLT) SETSIG(SIGSTKFLT,0); /* Stack fault */ #endif SETSIG(SIGFPE,0); SETSIG(SIGILL,0); SETSIG(SIGTRAP,0); /* Should be switched off when used with debuggers */ SETSIG(SIGINT,0); /* Also, see ifssig.c : used as a RESTART signal, confusingly enough */ if (atp_enabled) { /* We let ATP to catch SIGQUIT (it uses this for non-failed tasks, we think) -- thus commented out */ /* SETSIG(SIGQUIT,0); */ /* Unless ATP ignores SIGTERM, we ignore it from DrHook -- thus conditionally commented out */ if (atp_ignore_sigterm) SETSIG(SIGTERM,0); /* Means: DrHook does NOT ignore SIGTERM -- ATP does */ } else { SETSIG(SIGQUIT,0); SETSIG(SIGTERM,0); } #if defined(SIGIOT) SETSIG(SIGIOT,0); /* Same as SIGABRT; Used to be a typo SIGIO ;-( */ #endif SETSIG(SIGXCPU,1); /* ignore_atexit == 1 i.e. no profile info via atexit() */ #if defined(SIGXFSZ) SETSIG(SIGXFSZ,0); #endif #if defined(SIGDANGER) SETSIG(SIGDANGER,1); /* To catch the place where paging space gets dangerously low */ #endif SETSIG(SIGSYS,0); /* SETSIG(SIGCHLD); we may not want to catch this either; may interfere parallel processing */ /* -- not active SETSIG(SIGCHLD); SETSIG(SIGHUP); SETSIG(SIGCONT); */ #if defined(SIGCORE) SETSIG(SIGCORE,0); /* NEC SX core dumping */ #endif #if defined(SIGDEAD) SETSIG(SIGDEAD,0); /* NEC SX dead lock */ #endif #if defined(SIGXMEM) SETSIG(SIGXMEM,0); /* NEC SX exceeded memory size limit */ #endif #if defined(SIGXDSZ) SETSIG(SIGXDSZ,0); /* NEC SX exceeded data size limit */ #endif #if defined(SIGMEM32) SETSIG(SIGMEM32,0); /* NEC SX exceeded memory size limit of 32KB */ #endif #if defined(SIGNMEM) SETSIG(SIGNMEM,0); /* NEC SX exce error for no memory */ #endif #if defined(SIGXABT) SETSIG(SIGXABT,0); /* NEC SX distributed parallel program aborted */ #endif /* #if defined(SIG) SETSIG(SIG,0); #endif */ catch_signals(silent); /* Additional signals to be seen by DR_HOOK */ if (opt_gencore > 0 && opt_gencore_signal >= 1 && opt_gencore_signal <= NSIG) { drhook_sigfunc_t u; u.func3args = signal_gencore; signal(opt_gencore_signal, u.func1args); /* A facility to dump core */ } signals_set = 1; /* Signals are set now */ } /*--- get_mon_out ---*/ static char * get_mon_out(int me) { char *s = mon_out; if (mon_out_procs == me || (mon_out_procs == -1 && me >= 1 && me <= nproc)) { if (!mon_out) mon_out = strdup_drhook("drhook.prof.%d"); s = malloc_drhook((strlen(mon_out) + 20) * sizeof(*s)); sprintf(s,mon_out,me); } if (!s) s = strdup_drhook("drhook.prof.0"); return s; } /*--- get_memmon_out ---*/ static char * get_memmon_out(int me) { char *s = NULL; char *p = get_mon_out(me); if (p) { s = malloc_drhook((strlen(p) + 5) * sizeof(*s)); sprintf(s,"%s-mem",p); } if (!s) s = strdup_drhook("drhook.prof.0-mem"); return s; } /*--- get_memmon_out ---*/ static char * get_csv_out(int me) { char *s = NULL; char *p = get_mon_out(me); if (p) { s = malloc_drhook((strlen(p) + 5) * sizeof(*s)); sprintf(s,"%s.csv",p); } if (!s) s = strdup_drhook("drhook.prof.0.csv"); return s; } /*--- random_memstat ---*/ static void random_memstat(int tid, int enforce) { if (tid == 1 && opt_random_memstat > 0 && opt_random_memstat <= RAND_MAX) { int random_number = rand(); if (enforce || random_number % opt_random_memstat == 0) { long long int maxhwm = getmaxhwm_(); long long int maxstk = getmaxstk_(); if (drhook_stacksize_threshold > 0 && maxstk > drhook_stacksize_threshold) { /* Abort hopefully with traceback */ char *pfx = PREFIX(tid); long long int vmpeak = getvmpeak_() / (long long int) 1048576; long long int threshold = drhook_stacksize_threshold / (long long int) 1048576; long long int ompstk = drhook_oml_stacksize / (long long int) 1048576; maxstk /= (long long int) 1048576; maxhwm /= (long long int) 1048576; fprintf(stderr, "%s %s [%s@%s:%d] Stack usage [MB] very high : %lld > %lld (= %g x OMP_STACKSIZE=%lld ; maxhwm=%lld ; vmpeak=%lld)\n", pfx,TIMESTR(tid),FFL, maxstk,threshold, opt_trace_stack,ompstk, maxhwm,vmpeak); DRHOOK_ABORT(); } } } } /*--- process_options ---*/ static void do_prof(); #define OPTPRINT(fp,...) if (fp) fprintf(fp,__VA_ARGS__) static void process_options() { char *pfx = ""; char *env; FILE *fp = NULL; int tid, ienv; static int processed = 0; if (processed) return; tid = drhook_oml_get_thread_num(); env = getenv("DR_HOOK_SILENT"); if (env) { opt_silent = atoi(env); } env = getenv("DR_HOOK_SHOW_PROCESS_OPTIONS"); ienv = env ? atoi(env) : opt_silent ? 0 : 1; if (ienv == -1 || ienv == myproc) fp = stderr; if (fp) pfx = PREFIX(tid); if(fp) fprintf(fp,"[EC_DRHOOK:hostname:myproc:omltid:pid:unixtid] [YYYYMMDD:HHMMSS:walltime] [function@file:lineno] -- Max OpenMP threads = %d\n",drhook_oml_get_max_threads()); OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_SILENT=%d\n",pfx,TIMESTR(tid),FFL,opt_silent); void* fp_alias = (void*)fp; // Pass alias to avoid warning "passing argument 1 to ‘restrict’-qualified parameter aliases with argument 8" OPTPRINT(fp,"%s %s [%s@%s:%d] fp = %p\n",pfx,TIMESTR(tid),FFL,fp_alias); env = getenv("ATP_ENABLED"); atp_enabled = env ? atoi(env) : 0; if (atp_enabled) { env = getenv("ATP_MAX_CORES"); if (env) atp_max_cores = atoi(env); env = getenv("ATP_MAX_ANALYSIS_TIME"); if (env) atp_max_analysis_time = atoi(env); env = getenv("ATP_IGNORE_SIGTERM"); if (env) atp_ignore_sigterm = atoi(env); OPTPRINT(fp,"%s %s [%s@%s:%d] ATP_ENABLED=%d\n",pfx,TIMESTR(tid),FFL,atp_enabled); OPTPRINT(fp,"%s %s [%s@%s:%d] ATP_MAX_CORES=%d\n",pfx,TIMESTR(tid),FFL,atp_max_cores); OPTPRINT(fp,"%s %s [%s@%s:%d] ATP_MAX_ANALYSIS_TIME=%d\n",pfx,TIMESTR(tid),FFL,atp_max_analysis_time); OPTPRINT(fp,"%s %s [%s@%s:%d] ATP_IGNORE_SIGTERM=%d\n",pfx,TIMESTR(tid),FFL,atp_ignore_sigterm); } env = getenv("DR_HOOK_ALLOW_COREDUMP"); if (env) { ienv = atoi(env); allow_coredump = (ienv == -1 || ienv == myproc) ? ienv : 0; } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_ALLOW_COREDUMP=%d\n",pfx,TIMESTR(tid),FFL,allow_coredump); #if 0 // Postponed until DrHook actully has caught the signal if (allow_coredump) { unsigned long long int hardlimit = 0; int rc = set_unlimited_corefile(&hardlimit,1); if (rc == 0) { OPTPRINT(fp,"%s %s [%s@%s:%d] Hardlimit for core file is now %llu (0x%llx)\n", pfx,TIMESTR(tid),FFL,hardlimit,hardlimit); } } #endif env = getenv("DR_HOOK_PROFILE"); if (env) { char *s = calloc_drhook(strlen(env) + 15, sizeof(*s)); strcpy(s,env); if (!strchr(env,'%')) strcat(s,".%d"); mon_out = strdup_drhook(s); free_drhook(s); } if (mon_out) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_PROFILE=%s\n",pfx,TIMESTR(tid),FFL,mon_out); env = getenv("DR_HOOK_PROFILE_PROC"); if (env) { mon_out_procs = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_PROFILE_PROC=%d\n",pfx,TIMESTR(tid),FFL,mon_out_procs); env = getenv("DR_HOOK_PROFILE_LIMIT"); if (env) { percent_limit = atof(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_PROFILE_LIMIT=%.3f\n",pfx,TIMESTR(tid),FFL,percent_limit); env = getenv("DR_HOOK_FUNCENTER"); if (env) { opt_funcenter = atoi(env); } if (opt_funcenter) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_FUNCENTER=%d\n",pfx,TIMESTR(tid),FFL,opt_funcenter); env = getenv("DR_HOOK_FUNCEXIT"); if (env) { opt_funcexit = atoi(env); } if (opt_funcexit) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_FUNCEXIT=%d\n",pfx,TIMESTR(tid),FFL,opt_funcexit); if (opt_funcenter || opt_funcexit) { opt_gethwm = opt_getstk = 1; } env = getenv("DR_HOOK_TIMELINE"); if (env) { opt_timeline = atoi(env); } if (opt_timeline) { OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMELINE=%d\n",pfx,TIMESTR(tid),FFL,opt_timeline); env = getenv("DR_HOOK_TIMELINE_THREAD"); if (env) { opt_timeline_thread = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMELINE_THREAD=%d\n",pfx,TIMESTR(tid),FFL,opt_timeline_thread); env = getenv("DR_HOOK_TIMELINE_FORMAT"); if (env) { opt_timeline_format = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMELINE_FORMAT=%d\n",pfx,TIMESTR(tid),FFL,opt_timeline_format); env = getenv("DR_HOOK_TIMELINE_UNITNO"); if (env) { opt_timeline_unitno = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMELINE_UNITNO=%d\n",pfx,TIMESTR(tid),FFL,opt_timeline_unitno); env = getenv("DR_HOOK_TIMELINE_FREQ"); if (env) { opt_timeline_freq = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMELINE_FREQ=%lld\n",pfx,TIMESTR(tid),FFL,opt_timeline_freq); env = getenv("DR_HOOK_TIMELINE_MB"); if (env) { opt_timeline_MB = atof(env); if (opt_timeline_MB < 0) opt_timeline_MB = 1.0; } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMELINE_MB=%g\n",pfx,TIMESTR(tid),FFL,opt_timeline_MB); } if (myproc == 1) { /* Only applicable for master MPI task for now */ env = getenv("DR_HOOK_TRACE_STACK"); if (env) { opt_trace_stack = atof(env); if (opt_trace_stack < 0) opt_trace_stack = 0; else { drhook_oml_stacksize = slave_stacksize(); if (drhook_oml_stacksize > 0) { drhook_stacksize_threshold = opt_trace_stack * drhook_oml_stacksize; opt_random_memstat = 1; random_memstat(1,1); OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TRACE_STACK=%g\n",pfx,TIMESTR(tid),FFL,opt_trace_stack); } else opt_trace_stack = 0; } } } if (!opt_random_memstat) { env = getenv("DR_HOOK_RANDOM_MEMSTAT"); if (env) { opt_random_memstat = atoi(env); if (opt_random_memstat < 0) opt_random_memstat = 0; if (opt_random_memstat > RAND_MAX) opt_random_memstat = RAND_MAX; random_memstat(1,1); } } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_RANDOM_MEMSTAT=%d (RAND_MAX=%d)\n",pfx,TIMESTR(tid),FFL,opt_random_memstat,RAND_MAX); env = getenv("DR_HOOK_HASHBITS"); if (env) { int value = atoi(env); if (value < 1) value = 1; else if (value > NHASHMAX) value = NHASHMAX; nhash = value; hashsize = HASHSIZE(nhash); hashmask = HASHMASK(nhash); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_HASHBITS=%d\n",pfx,TIMESTR(tid),FFL,nhash); env = getenv("DR_HOOK_NCALLSTACK"); if (env) { int value = atoi(env); if (value < 1) value = DR_HOOK_NCALLSTACK; cstklen = value; } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_NCALLSTACK=%d\n",pfx,TIMESTR(tid),FFL,cstklen); env = getenv("DR_HOOK_HARAKIRI_TIMEOUT"); if (env) { int value = atoi(env); if (value < 1) value = drhook_harakiri_timeout_default; drhook_harakiri_timeout = value; } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_HARAKIRI_TIMEOUT=%d\n",pfx,TIMESTR(tid),FFL,drhook_harakiri_timeout); env = getenv("DR_HOOK_USE_LOCKFILE"); if (env) { int value = atoi(env); drhook_use_lockfile = (value != 0) ? 1 : 0; /* currently accept just 0 or 1 */ } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_USE_LOCKFILE=%d\n",pfx,TIMESTR(tid),FFL,drhook_use_lockfile); env = getenv("DR_HOOK_TRAPFPE"); if (env) { int value = atoi(env); drhook_trapfpe = (value != 0) ? 1 : 0; /* currently accept just 0 or 1 */ } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TRAPFPE=%d\n",pfx,TIMESTR(tid),FFL,drhook_trapfpe); env = getenv("DR_HOOK_TRAPFPE_INVALID"); if (env) { int value = atoi(env); drhook_trapfpe_invalid = (value != 0) ? 1 : 0; /* currently accept just 0 or 1 */ } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TRAPFPE_INVALID=%d\n",pfx,TIMESTR(tid),FFL,drhook_trapfpe_invalid); env = getenv("DR_HOOK_TRAPFPE_DIVBYZERO"); if (env) { int value = atoi(env); drhook_trapfpe_divbyzero = (value != 0) ? 1 : 0; /* currently accept just 0 or 1 */ } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TRAPFPE_DIVBYZERO=%d\n",pfx,TIMESTR(tid),FFL,drhook_trapfpe_divbyzero); env = getenv("DR_HOOK_TRAPFPE_OVERFLOW"); if (env) { int value = atoi(env); drhook_trapfpe_overflow = (value != 0) ? 1 : 0; /* currently accept just 0 or 1 */ } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TRAPFPE_OVERFLOW=%d\n",pfx,TIMESTR(tid),FFL,drhook_trapfpe_overflow); env = getenv("DR_HOOK_TIMED_KILL"); if (env) { drhook_timed_kill = strdup_drhook(env); } if (drhook_timed_kill) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_TIMED_KILL=%s\n",pfx,TIMESTR(tid),FFL,drhook_timed_kill); env = getenv("DR_HOOK_DUMP_SMAPS"); if (env) { ienv = atoi(env); drhook_dump_smaps = (ienv != 0) ? 1 : 0; } if (drhook_dump_smaps) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_DUMP_SMAPS=%d\n",pfx,TIMESTR(tid),FFL,drhook_dump_smaps); env = getenv("DR_HOOK_DUMP_MAPS"); if (env) { ienv = atoi(env); drhook_dump_maps = (ienv != 0) ? 1 : 0; } if (drhook_dump_maps) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_DUMP_MAPS=%d\n",pfx,TIMESTR(tid),FFL,drhook_dump_maps); env = getenv("DR_HOOK_DUMP_BUDDYINFO"); if (env) { ienv = atoi(env); drhook_dump_buddyinfo = (ienv != 0) ? 1 : 0; } if (drhook_dump_buddyinfo) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_DUMP_BUDDYINFO=%d\n",pfx,TIMESTR(tid),FFL,drhook_dump_buddyinfo); env = getenv("DR_HOOK_DUMP_MEMINFO"); if (env) { ienv = atoi(env); drhook_dump_meminfo = (ienv != 0) ? 1 : 0; } if (drhook_dump_meminfo) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_DUMP_MEMINFO=%d\n",pfx,TIMESTR(tid),FFL,drhook_dump_meminfo); env = getenv("DR_HOOK_DUMP_HUGEPAGES"); if (env) { double freq; int nel = sscanf(env,"%d,%lf",&ienv,&freq); if (nel == 2) { drhook_dump_hugepages = (freq > 0 && (ienv == -1 || ienv == myproc)) ? ienv : 0; if (drhook_dump_hugepages) drhook_dump_hugepages_freq = freq; } } if (drhook_dump_hugepages) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_DUMP_HUGEPAGES=%d,%.6f\n",pfx,TIMESTR(tid),FFL, drhook_dump_hugepages,drhook_dump_hugepages_freq); env = getenv("DR_HOOK_GENCORE"); if (env) { opt_gencore = atoi(env); } if (opt_gencore) { OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_GENCORE=%d\n",pfx,TIMESTR(tid),FFL,opt_gencore); env = getenv("DR_HOOK_GENCORE_SIGNAL"); if (env) { int itmp = atoi(env); if (itmp >= 1 && itmp <= NSIG && itmp != SIGABRT) { opt_gencore_signal = itmp; } } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_GENCORE_SIGNAL=%d\n",pfx,TIMESTR(tid),FFL,opt_gencore_signal); } env = getenv("DR_HOOK_STRICT_REGIONS"); int strict_regions_opt_touched = 0; if (env) { opt_strict_regions = atoi(env); strict_regions_opt_touched = 1; } env = getenv("DR_HOOK_NVTX"); if (env) { opt_nvtx = atoi(env); opt_strict_regions = opt_strict_regions || opt_nvtx; strict_regions_opt_touched = 1; opt_walltime = 1; opt_calls = 1; OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_NVTX=%d\n",pfx,TIMESTR(tid),FFL,opt_nvtx); } if (opt_nvtx) { env = getenv("DR_HOOK_NVTX_SPAM_CALL_COUNT"); if (env) { opt_nvtx_SCC = atoi(env); if (opt_nvtx_SCC < 0) opt_nvtx_SCC = nvtx_SCC_default; OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_NVTX_SPAM_CALL_COUNT=%d\n",pfx,TIMESTR(tid),FFL,opt_nvtx_SCC); } env = getenv("DR_HOOK_NVTX_SPAM_WT"); if (env) { opt_nvtx_SWT = atof(env); if (opt_nvtx_SWT < 0) opt_nvtx_SWT = nvtx_SWT_default; OPTPRINT(fp, "%s %s [%s@%s:%d] DR_HOOK_NVTX_SPAM_WT=%g\n", pfx, TIMESTR(tid), FFL, nvtx_SWT_default); } } env = getenv("DR_HOOK_ROCTX"); if (env) { opt_roctx = atoi(env); opt_strict_regions = opt_strict_regions || opt_roctx; strict_regions_opt_touched = 1; opt_walltime = 1; opt_calls = 1; OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_ROCTX=%d\n",pfx,TIMESTR(tid),FFL,opt_roctx); } if (opt_roctx) { env = getenv("DR_HOOK_ROCTX_SPAM_CALL_COUNT"); if (env) { opt_roctx_SCC = atoi(env); if (opt_roctx_SCC < 0) opt_roctx_SCC = roctx_SCC_default; OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_ROCTX_SPAM_CALL_COUNT=%d\n",pfx,TIMESTR(tid),FFL,opt_roctx_SCC); } env = getenv("DR_HOOK_ROCTX_SPAM_WT"); if (env) { opt_roctx_SWT = atof(env); if (opt_roctx_SWT < 0) opt_roctx_SWT = roctx_SWT_default; OPTPRINT(fp, "%s %s [%s@%s:%d] DR_HOOK_ROCTX_SPAM_WT=%g\n", pfx, TIMESTR(tid), FFL, roctx_SWT_default); } } if (strict_regions_opt_touched) OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_STRICT_REGIONS=%d\n",pfx,TIMESTR(tid),FFL,opt_strict_regions); env = getenv("DR_HOOK_OPT"); if (env) { const char delim[] = ", \t/"; char *s = strdup_drhook(env); char *p = s; int n = strlen(s); /* * Due to 'NOPROP' being expanded to 'NOPROPAGATE_SIGNALS', we can * potentially need up to 4 times more output buffer length vs input. */ char *recognised_opts = calloc_drhook((4*n)+1, sizeof(*recognised_opts)); int recognised_opts_len = 0; char *unrecognised_opts = calloc_drhook(n+1, sizeof(*unrecognised_opts)); int unrecognised_opts_len = 0; while (*p) { if (islower(*p)) *p = toupper(*p); p++; } p = strtok(s,delim); while (p) { /* Assume that we are handling a recognised opt by default */ char *out = recognised_opts; int* len = &recognised_opts_len; /* * Some options have both shorthand and canonical names. Here we assume * we are given the canonical name by default, and then change the pointer * in the relevant option handler if we were given the shorthand instead. * Not all options have a shorthand name, e.g. "ALL", so by default p * must point ot the canonical name if matched. */ char* opt_name = p; /* Assume that everything is OFF by default */ if (strequ(p,"ALL")) { /* all except profiler data */ opt_gethwm = opt_getstk = opt_getrss = opt_getpag = opt_walltime = opt_cputime = opt_cycles = 1; opt_calls = 1; #ifdef DR_HOOK_HAVE_PAPI opt_papi = 1; #endif any_memstat++; } else if (strequ(p,"MEM") || strequ(p,"MEMORY")) { opt_gethwm = opt_getstk = opt_getrss = 1; opt_calls = 1; any_memstat++; opt_name = "MEMORY"; } else if (strequ(p,"TIME") || strequ(p,"TIMES")) { opt_walltime = opt_cputime = 1; opt_calls = 1; opt_name = "TIMES"; } else if (strequ(p,"HWM") || strequ(p,"HEAP")) { opt_gethwm = 1; opt_calls = 1; any_memstat++; opt_name = "HEAP"; } else if (strequ(p,"STK") || strequ(p,"STACK")) { opt_getstk = 1; opt_calls = 1; any_memstat++; opt_name = "STACK"; } else if (strequ(p,"RSS")) { opt_getrss = 1; opt_calls = 1; any_memstat++; } else if (strequ(p,"PAG") || strequ(p,"PAGING")) { opt_getpag = 1; opt_calls = 1; any_memstat++; opt_name = "PAGING"; } else if (strequ(p,"WALL") || strequ(p,"WALLTIME")) { opt_walltime = 1; opt_calls = 1; opt_name = "WALLTIME"; } else if (strequ(p,"CPU") || strequ(p,"CPUTIME")) { opt_cputime = 1; opt_calls = 1; opt_name = "CPUTIME"; } else if (strequ(p,"CALLS") || strequ(p,"COUNT")) { opt_calls = 1; opt_name = "CALLS"; } else if (strequ(p,"MEMPROF")) { opt_memprof = 1; opt_gethwm = opt_getstk = opt_getrss = 1; opt_getpag = 1; opt_calls = 1; any_memstat++; } else if (strequ(p,"PROF") || strequ(p,"WALLPROF") || strequ(p,"CYCLES")) { opt_wallprof = 1; opt_walltime = 1; opt_cpuprof = 0; /* Note: Switches cpuprof OFF */ opt_calls = 1; opt_cycles = 1; opt_name = "WALLPROF"; } else if (strequ(p,"COUNTERS") ) { opt_wallprof = 1; opt_walltime = 1; opt_cpuprof = 0; /* Note: Switches cpuprof OFF */ opt_calls = 1; opt_cycles = 1; #ifdef DR_HOOK_HAVE_PAPI opt_papi = 1; #endif } else if (strequ(p,"CPUPROF")) { opt_cpuprof = 1; opt_cputime = 1; opt_wallprof = 0; /* Note: Switches walprof OFF */ opt_calls = 1; } else if (strequ(p,"TRIM")) { opt_trim = 1; } else if (strequ(p,"SELF")) { opt_self = 2; } else if (strequ(p,"NOSELF")) { opt_self = 0; } else if (strequ(p,"NOPROP") || strequ(p,"NOPROPAGATE") || strequ(p,"NOPROPAGATE_SIGNALS")) { opt_propagate_signals = 0; opt_name = "NOPROPAGATE_SIGNALS"; } else if (strequ(p,"NOSIZE") || strequ(p,"NOSIZEINFO")) { opt_sizeinfo = 0; opt_name = "NOSIZEINFO"; } else if (strequ(p,"CLUSTER") || strequ(p,"CLUSTERINFO")) { opt_clusterinfo = 1; opt_name = "CLUSTERINFO"; } else if (strequ(p,"CALLPATH")) { opt_callpath = 1; } else if (strequ(p,"NONE")) { /* Used in certain applications to explictly denote no DR_HOOK_OPT options. Has no effect. */ } else { out = unrecognised_opts; len = &unrecognised_opts_len; } /* If there is something in the output buffer, i.e. we are extending the list. */ if (*len) { out[*len] = ','; *len += 1; } /* Copy the current opt into the buffer */ strcpy(out + *len, opt_name); *len += strlen(opt_name); p = strtok(NULL,delim); } free_drhook(s); if (recognised_opts_len) { OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_OPT=\"%s\"\n",pfx,TIMESTR(tid),FFL,recognised_opts); } free_drhook(recognised_opts); if (unrecognised_opts_len) { OPTPRINT(fp,"%s %s [%s@%s:%d] Warning - no match for DR_HOOK_OPT=\"%s\"\n",pfx,TIMESTR(tid),FFL,unrecognised_opts); } free_drhook(unrecognised_opts); if (opt_callpath) { env = getenv("DR_HOOK_CALLPATH_INDENT"); if (env) { callpath_indent = atoi(env); if (callpath_indent < 1 || callpath_indent > 8) callpath_indent = callpath_indent_default; } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_CALLPATH_INDENT=%d\n",pfx,TIMESTR(tid),FFL,callpath_indent); env = getenv("DR_HOOK_CALLPATH_DEPTH"); if (env) { callpath_depth = atoi(env); if (callpath_depth < 0) callpath_depth = callpath_depth_default; } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_CALLPATH_DEPTH=%d\n",pfx,TIMESTR(tid),FFL,callpath_depth); env = getenv("DR_HOOK_CALLPATH_PACKED"); if (env) { callpath_packed = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_CALLPATH_PACKED=%d\n",pfx,TIMESTR(tid),FFL,callpath_packed); env = getenv("DR_HOOK_CALLTRACE"); if (env) { opt_calltrace = atoi(env); } OPTPRINT(fp,"%s %s [%s@%s:%d] DR_HOOK_CALLTRACE=%d\n",pfx,TIMESTR(tid),FFL,opt_calltrace); } #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) { int newline = 0; env = getenv("DR_HOOK_PAPI_COUNTERS"); if (env) { const char delim[] = ", \t/"; char *comma = " DR_HOOK_PAPI_COUNTERS=\""; char *s = strdup_drhook(env); char *p = s; while (*p) { if (islower(*p)) *p = toupper(*p); p++; } p = strtok(s,delim); if (p && fp) { fprintf(fp,"%s %s [%s@%s:%d]",pfx,TIMESTR(tid),FFL); newline = 1; } for (int i = 0; p && i < drhook_papi_max_num_counters(); p = strtok(NULL,delim), i++) { drhook_papi_add_counter_name(strdup_drhook(p)); OPTPRINT(fp,"%s%s",comma,p); comma = ","; } free_drhook(s); if (*comma == ',') { OPTPRINT(fp,"\"\n"); newline = 0; } if (newline) OPTPRINT(fp,"\n"); } else { const char* default_events[4] = { "PAPI_TOT_CYC", "PAPI_FP_OPS", "PAPI_L1_DCA", "PAPI_L2_DCM" }; for (int i = 0; i < 4; i++) { drhook_papi_add_counter_name(strdup_drhook(default_events[i])); } } } #endif if (opt_wallprof || opt_cpuprof || opt_memprof || opt_timeline) { atexit(do_prof); } } else { if (opt_timeline) atexit(do_prof); } /* if (env) */ processed = 1; } /*--- trim ---*/ static const char * trim(const char *name, int *n) { const char *from; int len; int name_len = *n; while (*name && isspace(*name) && name_len > 0) { /* skip leading blanks */ name++; name_len--; } len = 0; from = name; while (*from && !isspace(*from) && name_len > 0) { /* find first space point, if any */ from++; len++; name_len--; } *n = len; if (!name) { /* Never actually called (unless a true fatality) */ ABOR1("***Fatal error in drhook.c:trim()-function"); } return name; } /*--- insertkey ---*/ static drhook_key_t * insertkey(int tid, const drhook_key_t *keyptr_in) { drhook_key_t *keyptr = NULL; if (tid >= 1 && tid <= numthreads) { /* no trimming available for this; just raw eval & insert */ unsigned int hash = hashfunc(keyptr_in->name, keyptr_in->name_len); keyptr = &keydata[tid-1][hash]; for (;;) { if (!keyptr->name) { /* A free slot */ memcpy(keyptr,keyptr_in,sizeof(*keyptr)); keyptr->next = NULL; break; } else { if (!keyptr->next) { keyptr->next = calloc_drhook(1, sizeof(drhook_key_t)); /* chaining */ } keyptr = keyptr->next; } /* if (!keyptr->name) ... else ... */ } /* for (;;) */ } /* if (tid >= 1 && tid <= numthreads) */ return keyptr; } /*--- getkey ---*/ static drhook_key_t * getkey(int tid, const char *name, int name_len, const char *filename, int filename_len, const double *walltime, const double *cputime, const long long int *cycles, const equivalence_t *callpath, int callpath_len, int *free_callpath) { drhook_key_t *keyptr = NULL; if (tid >= 1 && tid <= numthreads) { unsigned int hash, fullhash; if (opt_trim) name = trim(name, &name_len); hash = hashfunc(name, name_len); if (callpath) { callpath_hashfunc(hash, callpath, callpath_len, &fullhash); #ifdef DEBUG fprintf(stderr, "getkey: name='%.*s', name_len=%d, callpath_len=%d, fullhash=%u\n", name_len, name, name_len, callpath_len, fullhash); #endif } keyptr = &keydata[tid-1][hash]; for (;;) { int found = 0; if (!keyptr->name) { /* A free slot */ keyptr->name = malloc_drhook((name_len+1)*sizeof(*name)); keyptr->name_len = name_len; if (opt_trim) { const char *from = name; char *to = keyptr->name; int len = name_len; for (; len>0; from++, len--) { *to++ = islower(*from) ? toupper(*from) : *from; } *to = 0; } else { memcpy(keyptr->name, name, name_len); keyptr->name[name_len] = 0; } if (filename_len > 0 && filename && *filename) { char *psave = NULL; char *p = psave = malloc_drhook((filename_len+1)*sizeof(*filename)); memcpy(p, filename, filename_len); p[filename_len] = 0; { /* Strip out dirname */ char *s = strrchr(p,'/'); if (s) p = s+1; } keyptr->filename = strdup_drhook(p); free_drhook(psave); } if (callpath) { if (free_callpath) *free_callpath = 0; keyptr->callpath = callpath; keyptr->callpath_len = callpath_len; keyptr->callpath_fullhash = fullhash; } found = 1; } if (found || (keyptr->name_len == name_len && (!callpath || (callpath && keyptr->callpath && keyptr->callpath_len == callpath_len && keyptr->callpath_fullhash == fullhash)) && ((!opt_trim && *keyptr->name == *name && strnequ(keyptr->name, name, name_len)) || (opt_trim && strncasecmp(keyptr->name, name, name_len) == 0)))) { if (opt_walltime) keyptr->wall_in = walltime ? *walltime : WALLTIME(); if (opt_cputime) keyptr->cpu_in = cputime ? *cputime : CPUTIME(); if (opt_cycles) keyptr->cycles_in = cycles ? *cycles : ec_get_cycles(); #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) drhook_papi_readAll(keyptr->counters_in); #endif if (any_memstat) memstat(keyptr,&tid,1); if (opt_calls) { keyptr->calls++; keyptr->status++; } #if defined(DR_HOOK_HAVE_NVTX) // Helps filter out wrapper calls that may be noise if (opt_nvtx && tid == 1){ if (keyptr->calls > opt_nvtx_SCC && keyptr->delta_wall_all < opt_nvtx_SWT) { if (!opt_silent) fprintf(stderr,"DRHOOK:NVTX: Skipping opening of region %s\n", keyptr->name); keyptr->skipped_nvtx_calls++; } else dr_hook_nvtx_start(keyptr->name); } #endif #if defined(DR_HOOK_HAVE_ROCTX) // Helps filter out wrapper calls that may be noise if (opt_roctx && drhook_oml_get_thread_num() == 1){ if (keyptr->calls > opt_roctx_SCC && keyptr->delta_wall_all < opt_roctx_SWT) { if (!opt_silent) fprintf(stderr,"DRHOOK:ROCTX: Skipping opening of region %s\n", keyptr->name); keyptr->skipped_roctx_calls++; } else dr_hook_roctx_start(keyptr->name); } #endif insert_calltree(tid, keyptr); break; /* for (;;) */ } else { if (!keyptr->next) { keyptr->next = calloc_drhook(1, sizeof(drhook_key_t)); /* chaining */ } keyptr = keyptr->next; } /* if (found ...) else ... */ } /* for (;;) */ curkeyptr[tid-1] = keyptr; } /* if (tid >= 1 && tid <= numthreads) */ return keyptr; } /*--- putkey ---*/ static void putkey(int tid, drhook_key_t *keyptr, const char *name, int name_len, int sizeinfo, double *walltime, double *cputime, long long int *cycles) { const int sig = SIGABRT; const char sl_name[] = "SIGABRT"; drhook_calltree_t *treeptr = (tid >= 1 && tid <= numthreads) ? thiscall[tid-1] : NULL; int regions_mismatch = 0; if (opt_strict_regions) regions_mismatch = strncasecmp(keyptr->name, name, name_len); if (!treeptr || !treeptr->active || treeptr->keyptr != keyptr || regions_mismatch) { char *pfx = PREFIX(tid); char *s; unsigned int hash; if (opt_trim) name = trim(name, &name_len); hash = hashfunc(name, name_len); s = strdup2_drhook(name,name_len); if (opt_trim) { char *p = s; while (*p) { if (islower(*p)) *p = toupper(*p); p++; } } fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: Dr.Hook has detected an invalid" " key-pointer/handle while leaving the routine '%s' [hash=%u]\n", pfx,TIMESTR(tid),FFL, sig,sl_name,s,hash); if (treeptr) { equivalence_t u; u.keyptr = treeptr->keyptr; hash = (u.keyptr && u.keyptr->name) ? hashfunc(u.keyptr->name,u.keyptr->name_len) : 0; fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: Expecting the key-pointer=%p" " and treeptr->active-flag = 1\n", pfx,TIMESTR(tid),FFL, sig,sl_name,(void*)u.keyptr); fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: A probable routine missing the closing" " DR_HOOK-call is '%s' [hash=%u]\n", pfx,TIMESTR(tid),FFL, sig,sl_name, (u.keyptr && u.keyptr->name) ? u.keyptr->name : NIL, hash); u.keyptr = keyptr; hash = (u.keyptr && u.keyptr->name) ? hashfunc(u.keyptr->name,u.keyptr->name_len) : 0; fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: Got a key-pointer=%p" " and treeptr->active-flag = %d\n", pfx,TIMESTR(tid),FFL, sig,sl_name,(void*)u.keyptr,treeptr->active); fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: This key-pointer maybe associated with" " the routine '%s' [hash=%u]\n", pfx,TIMESTR(tid),FFL, sig,sl_name, (u.keyptr && u.keyptr->name) ? u.keyptr->name : NIL, hash); u.keyptr = curkeyptr[tid-1]; hash = (u.keyptr && u.keyptr->name) ? hashfunc(u.keyptr->name,u.keyptr->name_len) : 0; fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: The current key-pointer (=%p) thinks" " it maybe associated with the routine '%s' [hash=%u]\n", pfx,TIMESTR(tid),FFL, sig,sl_name, (void*) u.keyptr, (u.keyptr && u.keyptr->name) ? u.keyptr->name : NIL, hash); } free_drhook(s); fprintf(stderr, "%s %s [%s@%s:%d] [signal#%d(%s)]: Aborting...\n", pfx,TIMESTR(tid),FFL, sig,sl_name); DRHOOK_ABORT(); } else if (tid >= 1 && tid <= numthreads) { double delta_wall = 0; double delta_cpu = 0; long long int delta_cycles = 0; if (any_memstat) memstat(keyptr,&tid,0); if (opt_calls) keyptr->status--; if (opt_sizeinfo && sizeinfo > 0) { if (keyptr->sizeinfo == 0) { /* First time */ keyptr->min_sizeinfo = sizeinfo; keyptr->max_sizeinfo = sizeinfo; } else { keyptr->min_sizeinfo = MIN(keyptr->min_sizeinfo, sizeinfo); keyptr->max_sizeinfo = MAX(keyptr->max_sizeinfo, sizeinfo); } keyptr->sizeinfo += sizeinfo; } if (opt_cycles && cycles) { *cycles = ec_get_cycles(); delta_cycles = *cycles - keyptr->cycles_in; } if (opt_cputime && cputime) { *cputime = CPUTIME(); delta_cpu = *cputime - keyptr->cpu_in; } if (opt_walltime && walltime) { *walltime = WALLTIME(); delta_wall = *walltime - keyptr->wall_in; } if (opt_walltime) keyptr->delta_wall_all += delta_wall; if (opt_cputime) keyptr->delta_cpu_all += delta_cpu; if (opt_cycles) keyptr->delta_cycles_all += delta_cycles; #if defined(DR_HOOK_HAVE_NVTX) if (opt_nvtx && drhook_oml_get_thread_num() == 1) { if (keyptr->skipped_nvtx_calls > 0) { if (!opt_silent) fprintf(stderr, "DRHOOK:NVTX: Skipping closing of region %s\n", keyptr->name); keyptr->skipped_nvtx_calls--; } else { dr_hook_nvtx_end(); } } #endif #if defined(DR_HOOK_HAVE_ROCTX) if (opt_roctx && drhook_oml_get_thread_num() == 1) { if (keyptr->skipped_roctx_calls > 0) { if (!opt_silent) fprintf(stderr, "DRHOOK:ROCTX: Skipping closing of region %s\n", keyptr->name); keyptr->skipped_roctx_calls--; } else { dr_hook_roctx_end(); } } #endif long_long * delta_counters = NULL; #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) { delta_counters = alloca(drhook_papi_num_counters() * sizeof(long_long)); drhook_papi_bzero(delta_counters); drhook_papi_subtract(delta_counters, NULL, keyptr->counters_in); drhook_papi_add(NULL, keyptr->delta_counters_all, delta_counters); } #endif remove_calltree(tid, keyptr, &delta_wall, &delta_cpu, &delta_cycles, delta_counters); } } /*--- init_drhook ---*/ static void init_drhook(int ntids) { if (numthreads == 0 || !keydata || !calltree || !keyself || !overhead || !curkeyptr || !cstk) { int j; if (pid == -1) { /* Ensure that called just once */ { /* Invoke once : timers, memory counters etc. to "wake them up" */ (void) WALLTIME(); (void) CPUTIME(); (void) gethwm_(); (void) getmaxhwm_(); (void) getrss_(); (void) getmaxrss_(); (void) getstk_(); (void) getmaxstk_(); (void) getpag_(); } start_stamp = timestamp(); drhook_oml_init_lock(); ec_set_umask_(); pid = getpid(); signal_drhook_init(1); /* myproc gets set .. if not earlier */ process_options(); set_timed_kill(); drhook_lhook = 1; } if (!keydata) { keydata = malloc_drhook(sizeof(**keydata) * ntids); for (j=0; jname = strdup_drhook(name); keyptr->name_len = name_len; } } if (!overhead) { overhead = calloc_drhook(ntids,sizeof(*overhead)); } if (!curkeyptr) { curkeyptr = malloc_drhook(sizeof(**curkeyptr) * ntids); for (j=0; j= 0 && opt_timeline_freq >= 1 && (opt_timeline == myproc || opt_timeline == -1)) { timeline = calloc_drhook(ntids, sizeof(*timeline)); } if (timeline) { /* The first timeline-call */ const int ftnunitno = opt_timeline_unitno; const int master = 1; const int print_option = +7; int initlev = 0; c_drhook_print_(&ftnunitno, &master, &print_option, &initlev); } } } } /*-- overhead-macro --*/ #define OVERHEAD(tid,walltime_in,cputime_in,delta,calc_delta) \ if (overhead && tid >= 1 && tid <= numthreads) { \ if (calc_delta) { \ if (opt_walltime) delta = WALLTIME() - walltime_in; \ else if (opt_cputime) delta = CPUTIME() - cputime_in; \ else delta = 0; \ } \ overhead[tid-1] += delta; \ } /*--- itself ---*/ #define ITSELF_0 \ double delta = 0; \ drhook_key_t *keyptr_self = keyself ? itself(NULL,*thread_id,0,NULL,&walltime,&cputime) : NULL; #define ITSELF_1 \ if (keyptr_self) { \ (void) itself(keyptr_self,*thread_id,1,&delta,&walltime,&cputime); \ if (opt_wallprof) u.keyptr->delta_wall_child += delta; \ else u.keyptr->delta_cpu_child += delta; \ OVERHEAD(*thread_id,walltime,cputime,delta,0); \ } \ else { \ OVERHEAD(*thread_id,walltime,cputime,delta,1); \ } static drhook_key_t * itself(drhook_key_t *keyptr_self, int tid, int opt, double *delta_time, const double *walltime, const double *cputime) { drhook_key_t *keyptr = NULL; if (keyself) { keyptr = keyptr_self ? keyptr_self : keyself[tid-1]; if (opt == 0) { if (opt_wallprof) keyptr->wall_in = walltime ? *walltime : WALLTIME(); else keyptr->cpu_in = cputime ? *cputime : CPUTIME(); #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) drhook_papi_readAll(keyptr->counters_in); #endif keyptr->calls++; } else if (opt == 1) { double delta = 0; if (opt_wallprof) { delta = walltime ? (*walltime - keyptr->wall_in) : (WALLTIME() - keyptr->wall_in); keyptr->delta_wall_all += delta; } else { delta = cputime ? (*cputime - keyptr->cpu_in) : (CPUTIME() - keyptr->cpu_in); keyptr->delta_cpu_all += delta; } if (delta_time) *delta_time = delta; #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) { long_long cntrs_delta[MAXNPAPICNTRS]; /* cntrs_delta = current - counters_in */ drhook_papi_subtract(cntrs_delta, NULL, keyptr->counters_in); /* keyptr->delta_counters_all += cntrs_delta */ drhook_papi_add(NULL, keyptr->delta_counters_all,cntrs_delta); } #endif } } return keyptr; } /*--- commie -routines : adds "," i.e. comma after each 3 digit, e.g.: 1234567890 becomes more readable 1,234,567,890 */ static void lld_commie(long long int n, char sd[]) { const char comma = ','; char s[DRHOOK_STRBUF]; char *p; int len, ncommas; sprintf(s,"%lld",n); len = strlen(s); ncommas = (len-1)/3; if (ncommas > 0) { char *pd = sd + len + ncommas; *pd-- = 0; p = s + len - 1; len = 0; while (p-s >= 0) { *pd-- = *p--; len++; if (p-s >= 0 && len%3 == 0) *pd-- = comma; } } else { strcpy(sd,s); } } static void dbl_commie(double n, char sd[]) { const char comma = ','; char s[DRHOOK_STRBUF]; char *p; int len, ncommas; sprintf(s,"%.0f",n); len = strlen(s); ncommas = (len-1)/3; if (ncommas > 0) { char *pd = sd + len + ncommas; *pd-- = 0; p = s + len - 1; len = 0; while (p-s >= 0) { *pd-- = *p--; len++; if (p-s >= 0 && len%3 == 0) *pd-- = comma; } } else { strcpy(sd,s); } } /*--- callpath as a "pathname" ---*/ static void unroll_callpath(FILE *fp, int len, const equivalence_t *callpath, int callpath_len) { if (fp && callpath && callpath_len > 0) { int j; for (j=0; jkeyptr && callpath->keyptr->name) { const char *name = callpath->keyptr->name; int name_len = callpath->keyptr->name_len; len -= callpath_indent; if (len < 0) len = 0; fprintf(fp,"\n%*s%.*s",len," ",name_len,name); } #ifdef DEBUG else { fprintf(fp, "\n????callpath=%p, callpath->keyptr=%p, callpath->keyptr->name='%s'", callpath, callpath ? callpath->keyptr : 0, (callpath && callpath->keyptr && callpath->keyptr->name) ? callpath->keyptr->name : NIL); } #endif } } /* if (fp) */ } static equivalence_t * get_callpath(int tid, int *callpath_len) { int depth = 0; equivalence_t *callpath = NULL; if (tid >= 1 && tid <= numthreads) { const drhook_calltree_t *treeptr = thiscall[tid-1]; while (treeptr && treeptr->active && depth < callpath_depth) { depth++; treeptr = treeptr->prev; } if (depth > 0) { int j = 0; callpath = malloc_drhook(sizeof(*callpath) * depth); treeptr = thiscall[tid-1]; while (treeptr && treeptr->active && j < callpath_depth) { callpath[j].keyptr = treeptr->keyptr; j++; treeptr = treeptr->prev; } } /* if (depth > 0) */ } /* if (tid >= 1 && tid <= numthreads) */ if (callpath_len) *callpath_len = depth; return callpath; } /*--- profiler output ---*/ static int do_prof_off = 0; static void do_prof() { /* to avoid recursive signals while atexit() (e.g. SIGXCPU) */ if (signal_handler_ignore_atexit) return; if (!do_prof_off && (opt_wallprof || opt_cpuprof)) { /* CPU or wall-clock profiling */ const int ftnunitno = 0; const int master = 1; const int print_option = 3; int initlev = 0; c_drhook_print_(&ftnunitno, &master, &print_option, &initlev); } if (!do_prof_off && (opt_papi)) { /* CPU or wall-clock profiling */ const int ftnunitno = 0; const int master = 1; const int print_option = 3; int initlev = 0; c_drhook_print_(&ftnunitno, &master, &print_option, &initlev); } if (!do_prof_off && opt_memprof) { /* Memory profiling */ const int ftnunitno = 0; const int master = 1; const int print_option = 4; int initlev = 0; c_drhook_print_(&ftnunitno, &master, &print_option, &initlev); } if (!do_prof_off && timeline) { /* The last timeline-call */ const int ftnunitno = opt_timeline_unitno; const int master = 1; const int print_option = -7; int initlev = 0; c_drhook_print_(&ftnunitno, &master, &print_option, &initlev); } } void c_drhook_prof_() { if (ec_drhook) { do_prof(); do_prof_off = 1; } } /*--- Check watch points ---*/ // Forward declarations of subroutines defined in dr_hook_prt.F90 extern void dr_hook_prt_logical_( const int *kunit, const void *ptr, const int *n ); extern void dr_hook_prt_char_( const int *kunit, const void *ptr, const int *n ); extern void dr_hook_prt_i4_( const int *kunit, const void *ptr, const int *n ); extern void dr_hook_prt_i8_( const int *kunit, const void *ptr, const int *n ); extern void dr_hook_prt_r4_( const int *kunit, const void *ptr, const int *n ); extern void dr_hook_prt_r8_( const int *kunit, const void *ptr, const int *n ); typedef enum { /* See dr_hook_watch_mod.F90 */ KEYNONE = 0, KEYLOG = 1, KEYCHAR = 2, KEY_I4 = 4, KEY_I8 = 8, KEY_R4 = 16, KEY_R8 = 32 } PrintWatchKeys_t; static void print_watch(int ftnunitno, int key, const void *ptr, int n) { if (ptr && key > KEYNONE && n > 0) { char *env = getenv("DR_HOOK_WATCH_PRINT_MAX"); int prtmax = env ? atoi(env) : -1; int nmax = n; if (prtmax >= 0 && prtmax < nmax) { nmax = prtmax; } if (nmax > 0) { if (key == KEYLOG) { dr_hook_prt_logical_(&ftnunitno, ptr, &nmax); } else if (key == KEYCHAR) { dr_hook_prt_char_(&ftnunitno, ptr, &nmax); } else if (key == KEY_I4) { dr_hook_prt_i4_(&ftnunitno, ptr, &nmax); } else if (key == KEY_I8) { dr_hook_prt_i8_(&ftnunitno, ptr, &nmax); } else if (key == KEY_R4) { dr_hook_prt_r4_(&ftnunitno, ptr, &nmax); } else if (key == KEY_R8) { dr_hook_prt_r8_(&ftnunitno, ptr, &nmax); } } } } static void check_watch(const char *label, const char *name, int name_len, int allow_abort) { if (watch) { int print_traceback = 1; drhook_watch_t *p = watch; drhook_oml_set_lock(); while (p) { if (p->active) { unsigned int crc32 = 0; int calc_crc = 0; const char *first_nbytes = p->ptr; int changed = memcmp(first_nbytes,p->ptr,p->watch_first_nbytes); if (!changed) { /* The first nbytes were still the same; checking if crc has changed ... */ crc32_(p->ptr, &p->nbytes, &crc32); changed = (crc32 != p->crc32); calc_crc = 1; } if (changed) { int tid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); if (!calc_crc) crc32_(p->ptr, &p->nbytes, &crc32); fprintf(stderr, "%s %s [%s@%s:%d] ***%s: Watch point '%s' value(s) changed at address %p (%d bytes [#%d values])" " -- %s %.*s : new crc32=0x%x\n", pfx,TIMESTR(tid),FFL, p->abort_if_changed ? "Error" : "Warning", p->name, (void*) p->ptr, p->nbytes, p->nvals, label, name_len, name, crc32); print_watch(0, p->printkey, p->ptr, p->nvals); if (print_traceback) { LinuxTraceBack(pfx,TIMESTR(tid),NULL); print_traceback = 0; } if (allow_abort && p->abort_if_changed) { drhook_oml_unset_lock(); /* An important unlocking on Linux; otherwise hangs (until time-out) */ DRHOOK_ABORT(); } #if 0 p->active = 0; /* No more these messages for this array */ watch_count--; #else p->crc32 = crc32; #endif } } p = p->next; } /* while (p) */ drhook_oml_unset_lock(); } } void c_drhook_check_watch_(const char *where, const int *allow_abort /* Hidden length */ , int where_len) { if (watch && watch_count > 0) check_watch("whilst at", where, where_len, *allow_abort); } /*** PUBLIC ***/ #if defined(DR_HOOK_HAVE_PAPI) #define PAPIREAD \ if (opt_papi) { \ long_long cntrs[MAXNPAPICNTRS]; \ drhook_papi_readAll(cntrs); \ } #else #define PAPIREAD /*NOOP*/ #endif #define TIMERS \ double walltime = opt_walltime ? WALLTIME() : 0; \ double cputime = opt_cputime ? CPUTIME() : 0; \ long long int cycles = opt_cycles ? ec_get_cycles() : 0; \ long long int hwm = opt_gethwm ? gethwm_() : 0; \ long long int stk = opt_getstk ? getstk_() : 0; \ PAPIREAD /*=== c_drhook_set_lhook_ ===*/ void c_drhook_set_lhook_(const int *lhook) { if (lhook) drhook_lhook = *lhook; } /*=== c_drhook_getenv_ ===*/ void c_drhook_getenv_(const char *s, char *value, /* Hidden arguments */ int slen, const int valuelen) { char *env = NULL; char *p = malloc_drhook(slen+1); if (!p) { fprintf(stderr,"c_drhook_getenv_(): Unable to allocate %d bytes of memory\n", slen+1); DRHOOK_ABORT(); } memcpy(p,s,slen); p[slen]='\0'; memset(value, ' ', valuelen); env = getenv(p); if (env) { int len = strlen(env); if (valuelen < len) len = valuelen; memcpy(value,env,len); } free_drhook(p); } /*=== c_drhook_init_ ===*/ extern void tabort_delete_lockfile(); static void drhook_delete_lockfile() { if (access(drhook_lockfile, F_OK) != -1) { // File is found remove(drhook_lockfile); } } void c_drhook_init_(const char *progname, const int *num_threads /* Hidden length */ ,int progname_len) { init_drhook(*num_threads); //max_threads = MAX(1,*num_threads); if (a_out) free_drhook(a_out); progname = trim(progname, &progname_len); if (progname_len > 0) { a_out = calloc_drhook(progname_len+1,sizeof(*progname)); memcpy(a_out, progname, progname_len); } else { /* progname is a blank string; this is most likely due to a Fortran-call to getarg from program that has a C-main program, thus Fortran getarg may return a blank string */ const char *arg0 = ec_argv()[0]; if (arg0) { const char *pc = arg0; progname_len = strlen(pc); pc = trim(pc, &progname_len); a_out = strdup_drhook(pc); } } if (!a_out) { a_out = strdup_drhook("a.out"); /* Failed to obtain the name of the executing program */ } if (myproc == 1) { /* myproc is set earlier in this routine within "init_drhook" */ tabort_delete_lockfile(); drhook_delete_lockfile(); } #if defined(DR_HOOK_HAVE_PAPI) if (opt_papi) drhook_papi_init(myproc -1); #endif } /*=== c_drhook_watch_ ===*/ void c_drhook_watch_(const int *onoff, const char *array_name, const void *array_ptr, const int *nbytes, const int *abort_if_changed, const int *printkey, const int *nvals, const int *print_traceback_when_set /* Hidden length */ ,int array_name_len) { int tid = drhook_oml_get_thread_num(); drhook_watch_t *p = NULL; if (!drhook_lhook) return; drhook_oml_set_lock(); /* check whether this array_ptr is already registered, but maybe inactive */ p = watch; while (p) { if (p->ptr == array_ptr) { if (p->active) watch_count--; free_drhook(p->name); break; } p = p->next; } if (!p) { /* create new branch */ p = calloc_drhook(1, sizeof(*p)); /* Implies p->next = NULL */ if (!last_watch) { last_watch = watch = p; } else { last_watch->next = p; last_watch = p; } } p->name = strdup2_drhook(array_name,array_name_len); p->tid = tid; p->active = *onoff; if (p->active) watch_count++; p->abort_if_changed = *abort_if_changed; p->ptr = array_ptr; p->nbytes = *nbytes; p->watch_first_nbytes = MIN(p->nbytes, MAX_WATCH_FIRST_NBYTES); memcpy(p->first_nbytes,p->ptr,p->watch_first_nbytes); p->crc32 = 0; crc32_(p->ptr, &p->nbytes, &p->crc32); p->printkey = *printkey; p->nvals = *nvals; { char *pfx = PREFIX(p->tid); int ftnunitno = 0; int textlen = strlen(pfx) + strlen(p->name) + 256; char *text = malloc_drhook(textlen * sizeof(*text)); snprintf(text,textlen, "%s ***Warning: Watch point '%s' set at address %p (%d bytes [%d values]) : crc32=0x%x", pfx, p->name, (void*) p->ptr, p->nbytes, p->nvals, p->crc32); dr_hook_prt_(&ftnunitno, text, strlen(text)); print_watch(ftnunitno, p->printkey, p->ptr, p->nvals); free_drhook(text); if (*print_traceback_when_set) LinuxTraceBack(pfx,TIMESTR(p->tid),NULL); } drhook_oml_unset_lock(); } /*=== c_drhook_start_ ===*/ void c_drhook_start_(const char *name, const int *thread_id, double *key, const char *filename, const int *sizeinfo /* Hidden length */ ,int name_len, int filename_len) { TIMERS; equivalence_t u; ITSELF_0; if (!signals_set) signal_drhook_init(1); if (name_len > 0 && opt_funcenter == *thread_id) { fprintf(stdout," %d %d %.*s %lld %lld\n",myproc,*thread_id,name_len,name,hwm,stk); fflush(stdout); } if (watch && watch_count > 0) check_watch("when entering routine", name, name_len, 1); if (drhook_dump_hugepages) { int tid = *thread_id; char *pfx = PREFIX(tid); dump_hugepages(0,pfx,tid,0,-1); } if (!opt_callpath) { u.keyptr = getkey(*thread_id, name, name_len, filename, filename_len, &walltime, &cputime, &cycles, NULL, 0, NULL); } else { /* (Much) more overhead */ int free_callpath = 1; int callpath_len = 0; equivalence_t *callpath = get_callpath(*thread_id, &callpath_len); u.keyptr = getkey(*thread_id, name, name_len, filename, filename_len, &walltime, &cputime, &cycles, callpath, callpath_len, &free_callpath); if (free_callpath) free_drhook(callpath); } if (cstklen == 0) { /* Double precision */ *key = u.d; } else { /* Single precision : The variable "*key" is treated like max 4-byte entity -- "an index" */ (void) callstack(*thread_id, key, u.keyptr); } ITSELF_1; if (opt_calltrace) { drhook_oml_set_lock(); { const int ftnunitno = 0; /* stderr */ const int print_option = 2; /* calling tree */ int level = 0; c_drhook_print_(&ftnunitno, thread_id, &print_option, &level); /* fprintf(stderr,"%d#%d> %*.*s [%llu]\n",myproc,*thread_id,name_len,name_len,name,u.ull); */ } drhook_oml_unset_lock(); } if (timeline) { int tid = *thread_id; if (opt_timeline_thread <= 0 || tid <= opt_timeline_thread) { drhook_timeline_t *tl = &timeline[tid-1]; int bigjump = 1; unsigned long long int mod = (tl->calls[0]++)%opt_timeline_freq; double rss = (double)(getrss_()/1048576.0); /* in MBytes */ double curheap = (opt_timeline_thread == 1 && tid == 1) ? (double)(getcurheap_()/1048576.0) : (double)(getcurheap_thread_(&tid)/1048576.0); /* in MBytes */ double stack = (double)(getstk_()/1048576.0); /* in MBytes */ double vmpeak = (double)(getvmpeak_()/1048576.0); /* in MBytes */ if (mod != 0) { double inc_MB; inc_MB = tl->last_rss_MB - rss; if (ABS(inc_MB) < opt_timeline_MB) inc_MB = tl->last_curheap_MB - curheap; if (ABS(inc_MB) < opt_timeline_MB) inc_MB = tl->last_stack_MB - stack; if (ABS(inc_MB) < opt_timeline_MB) inc_MB = tl->last_vmpeak_MB - vmpeak; if (ABS(inc_MB) < opt_timeline_MB) bigjump = 0; } if (mod == 0 || bigjump) { drhook_oml_set_lock(); { int ftnunitno = opt_timeline_unitno; const int print_option = 5; /* calling "tree" with just the current entry */ int level = 0; tl->last_rss_MB = rss; tl->last_curheap_MB = curheap; tl->last_stack_MB = stack; tl->last_vmpeak_MB = vmpeak; c_drhook_print_(&ftnunitno, &tid, &print_option, &level); } drhook_oml_unset_lock(); } } /* if (opt_timeline_thread <= 0 || tid <= opt_timeline_thread) */ } if (opt_random_memstat > 0) random_memstat(*thread_id,0); } /*=== c_drhook_end_ ===*/ void c_drhook_end_(const char *name, const int *thread_id, const double *key, const char *filename, const int *sizeinfo /* Hidden length */ ,int name_len, int filename_len) { TIMERS; equivalence_t u; ITSELF_0; if (cstklen == 0) { /* Double precision */ u.d = *key; } else { /* Single precision : The variable "*key" is treated like max 4-byte entity -- "an index" */ u.keyptr = callstack(*thread_id, (void *)key, NULL); } /* if (opt_calltrace) { drhook_oml_set_lock(); fprintf(stderr,"%d#%d< %*.*s [%llu]\n",myproc,*thread_id,name_len,name_len,name,u.ull); drhook_oml_unset_lock(); } */ if (name_len > 0 && opt_funcexit == *thread_id) { fprintf(stdout," %d %d %.*s %lld %lld\n",myproc,*thread_id,name_len,name,hwm,stk); fflush(stdout); } if (timeline) { int tid = *thread_id; if (opt_timeline_thread <= 0 || tid <= opt_timeline_thread) { drhook_timeline_t *tl = &timeline[tid-1]; int bigjump = 1; unsigned long long int mod = (tl->calls[1]++)%opt_timeline_freq; double rss = (double)(getrss_()/1048576.0); /* in MBytes */ double curheap = (opt_timeline_thread == 1 && tid == 1) ? (double)(getcurheap_()/1048576.0) : (double)(getcurheap_thread_(&tid)/1048576.0); /* in MBytes */ double stack = (double)(getstk_()/1048576.0); /* in MBytes */ double vmpeak = (double)(getvmpeak_()/1048576.0); /* in MBytes */ if (mod != 0) { double inc_MB; inc_MB = tl->last_rss_MB - rss; if (ABS(inc_MB) < opt_timeline_MB) inc_MB = tl->last_curheap_MB - curheap; if (ABS(inc_MB) < opt_timeline_MB) inc_MB = tl->last_stack_MB - stack; if (ABS(inc_MB) < opt_timeline_MB) inc_MB = tl->last_vmpeak_MB - vmpeak; if (ABS(inc_MB) < opt_timeline_MB) bigjump = 0; } if (mod == 0 || bigjump) { drhook_oml_set_lock(); { int ftnunitno = opt_timeline_unitno; const int print_option = -5; /* calling "tree" with just the current entry */ int level = 0; tl->last_rss_MB = rss; tl->last_curheap_MB = curheap; tl->last_stack_MB = stack; tl->last_vmpeak_MB = vmpeak; c_drhook_print_(&ftnunitno, &tid, &print_option, &level); } drhook_oml_unset_lock(); } } /* if (opt_timeline_thread <= 0 || tid <= opt_timeline_thread) */ } if (watch && watch_count > 0) check_watch("when leaving routine", name, name_len, 1); putkey(*thread_id, u.keyptr, name, name_len, *sizeinfo, &walltime, &cputime, &cycles); ITSELF_1; } /*=== c_drhook_memcounter_ ===*/ void c_drhook_memcounter_(const int *thread_id, const long long int *size, long long int *keyptr_addr) { int tid = (thread_id && (*thread_id >= 1) && (*thread_id <= numthreads)) ? *thread_id : drhook_oml_get_thread_num(); int has_timeline = (timeline && size) ? opt_timeline : 0; if (has_timeline) { if (opt_timeline_thread <= 1 || tid <= opt_timeline_thread) { double size_MB = (double)((*size)/1048576.0); /* In MBytes */ if (ABS(size_MB) < opt_timeline_MB) has_timeline = 0; /* Do not report */ } else { has_timeline = 0; /* Do not report */ } } /* if (has_timeline) */ if (opt_memprof) { if (size) { union { long long int keyptr_addr; drhook_key_t *keyptr; } u; long long int alldelta; if (*size > 0) { /* Memory is being allocated */ if (curkeyptr[tid-1]) { drhook_key_t *keyptr = curkeyptr[tid-1]; keyptr->mem_curdelta += *size; alldelta = keyptr->mem_curdelta + keyptr->mem_child; if (alldelta > keyptr->maxmem_alldelta) keyptr->maxmem_alldelta = alldelta; if (keyptr->mem_curdelta > keyptr->maxmem_selfdelta) keyptr->maxmem_selfdelta = keyptr->mem_curdelta; if (keyptr_addr) { u.keyptr = keyptr; *keyptr_addr = u.keyptr_addr; } keyptr->alloc_count++; } else { if (keyptr_addr) *keyptr_addr = 0; } /* if (curkeyptr[tid-1]) */ /* fprintf(stderr, "memcounter: allocated %lld bytes ; *keyptr_addr = %lld\n", *size, *keyptr_addr); */ } else { /* Memory is being freed */ drhook_key_t *keyptr; if (keyptr_addr && (*keyptr_addr)) { u.keyptr_addr = *keyptr_addr; keyptr = u.keyptr; } else keyptr = curkeyptr[tid-1]; /* fprintf(stderr, "memcounter: DE-allocated %lld bytes ; *keyptr_addr = %lld\n", *size, *keyptr_addr); */ if (keyptr) { long long int prev_curdelta = keyptr->mem_curdelta; keyptr->mem_curdelta += *size; alldelta = prev_curdelta + keyptr->mem_child; if (alldelta > keyptr->maxmem_alldelta) keyptr->maxmem_alldelta = alldelta; if (*size < 0) keyptr->free_count++; } /* if (keyptr) */ } /* if (*size > 0) ... else */ } /* if (size) */ } /* if (opt_memprof) */ if (has_timeline) { double curheap = (opt_timeline_thread == 1 && tid == 1) ? (double)(getcurheap_()/1048576.0) : (double)(getcurheap_thread_(&tid)/1048576.0); /* in MBytes */ double rss = (double)(getrss_()/1048576.0); /* in MBytes */ double stack = (double)(getstk_()/1048576.0); /* in MBytes */ double vmpeak = (double)(getvmpeak_()/1048576.0); /* in MBytes */ drhook_oml_set_lock(); { int ftnunitno = opt_timeline_unitno; double size_MB = (double)((*size)/1048576.0); /* In MBytes */ int print_option = (size_MB > 0) ? 6 : -6; /* timeline upon c_drhook_memcounter_ & (big) ALLOCATE or DEALLOCATE */ int level = 0; drhook_timeline_t *tl = &timeline[tid-1]; tl->last_curheap_MB = curheap; tl->last_rss_MB = rss; tl->last_stack_MB = stack; tl->last_vmpeak_MB = vmpeak; c_drhook_print_(&ftnunitno, &tid, &print_option, &level); } drhook_oml_unset_lock(); } /* if (has_timeline) */ } /*=== c_drhook_print_ ===*/ #define PRINT_HWM() \ if (opt_gethwm) { sprintf(s,",hwm=%lldK",keyptr->hwm/1024); s += strlen(s); } #define PRINT_RSS() \ if (opt_getrss) { \ sprintf(s,",rss/max=%lldK/%lldK",keyptr->rssnow/1024, keyptr->maxrss/1024); \ s += strlen(s); \ } #define PRINT_STK() \ if (opt_getstk) { \ sprintf(s,",stack/max=%lldK/%lldK",keyptr->stack/1024, keyptr->maxstack/1024); \ s += strlen(s); \ } #define PRINT_PAG() \ if (opt_getpag) { \ sprintf(s,",pag=%lld",keyptr->paging); \ s += strlen(s); \ } #define PRINT_WALL() \ if (opt_walltime) { \ double self = keyptr->delta_wall_all-keyptr->delta_wall_child; \ if (self < 0) self = 0; \ sprintf(s,",wall=%.3fs/%.3fs", \ keyptr->delta_wall_all, self); \ s += strlen(s); \ } #define PRINT_CPU() \ if (opt_cputime) { \ double self = keyptr->delta_cpu_all-keyptr->delta_cpu_child; \ if (self < 0) self = 0; \ sprintf(s,",cpu=%.3fs/%.3fs", \ keyptr->delta_cpu_all, self); \ s += strlen(s); \ } #define PRINT_CALLS() \ if (opt_calls) { \ sprintf(s,",#%llu,st=%d",keyptr->calls,keyptr->status); \ s += strlen(s); \ } static int prof_name_comp(const void *v1, const void *v2) { const drhook_prof_t *p1 = v1; const drhook_prof_t *p2 = v2; return strcmp(p1->name,p2->name); } static int memprof_name_comp(const void *v1, const void *v2) { const drhook_memprof_t *p1 = v1; const drhook_memprof_t *p2 = v2; return strcmp(p1->name,p2->name); } static int prof_pc_comp_desc(const void *v1, const void *v2) { const drhook_prof_t *p1 = v1; const drhook_prof_t *p2 = v2; if (p1->pc < p2->pc) return 1; else if (p1->pc > p2->pc) return -1; else return 0; } static int memprof_pc_comp_desc(const void *v1, const void *v2) { const drhook_memprof_t *p1 = v1; const drhook_memprof_t *p2 = v2; if (p1->pc < p2->pc) return 1; else if (p1->pc > p2->pc) return -1; else return 0; } static const char * trim_and_adjust_left(const char *p, int *name_len) { int len = strlen(p); if (len > 0) { const char *back = &p[len-1]; while (len > 0 && *back-- == ' ') len--; while (len > 0 && *p == ' ') { p++; len--; } } if (name_len) *name_len = len; return p; } static void print_routine_name0(FILE * fp, const char * p_name, int p_tid, const char * p_filename, int p_cluster, const equivalence_t * p_callpath, int p_callpath_len, int len, int cluster_size) { int name_len = 0; const char *name = trim_and_adjust_left(p_name,&name_len); if (callpath_packed) { if (p_callpath && p_callpath_len > 0) { const equivalence_t * callpath = &p_callpath[p_callpath_len-1]; int j; for (j=0; jkeyptr && callpath->keyptr->name) { const char *name = callpath->keyptr->name; int name_len = callpath->keyptr->name_len; fprintf(fp,"%.*s/",name_len,name); } } } fprintf(fp,"%.*s@%d%s%s", name_len, name, p_tid, p_filename ? ":" : "", p_filename ? p_filename : ""); if (opt_clusterinfo) { fprintf(fp," [%d,%d]", p_cluster, ABS(cluster_size)); } if (!callpath_packed) unroll_callpath(fp, len, p_callpath, p_callpath_len); } #define print_routine_name(fp, p, len, cluster_size) \ if (fp && p) { \ print_routine_name0(fp, p->name, p->tid, p->filename, p->cluster, \ p->callpath, p->callpath_len, len, cluster_size);\ } /* if (fp && p) */ static void DrHookPrint(int ftnunitno, const char *line) { if (line) { FILE *fp = NULL; if (ftnunitno <= 0) fp = stderr; else if (ftnunitno == 6) fp = stdout; else dr_hook_prt_(&ftnunitno, line, strlen(line)); OPTPRINT(fp,"%s\n",line); } } void c_drhook_print_(const int *ftnunitno, const int *thread_id, const int *print_option, /* 1=raw call counts 2=calling tree 3=profiling info 4=memory profiling 5=timeline upon entering the routine -5=timeline upon leaving the routine 6=timeline upon c_drhook_memcounter_ & (big) ALLOCATE -6=timeline upon c_drhook_memcounter_ & (big) DEALLOCATE 7=timeline : the very first call (upon setup or dr.hook) -7=timeline : the very last call (in atexit()) */ int *level ) { static int first_time = 0; int tid = (thread_id && (*thread_id >= 1) && (*thread_id <= numthreads)) ? *thread_id : drhook_oml_get_thread_num(); int mytid = drhook_oml_get_thread_num(); char *pfx = PREFIX(tid); if (ftnunitno && keydata && calltree) { char line[8192]; int abs_print_option = ABS(*print_option); int j; /* Mod to call traceback and continue if called with level=99 */ if(*level == 99) { *level=0; } else { if(*print_option == 2) { if(first_time == 1) return; first_time = 1; } } /* end of Mod */ if (*print_option == 1) { /* raw call counts */ for (j=0; j<(int)(hashsize); j++) { int nestlevel = 0; drhook_key_t *keyptr = &keydata[tid-1][j]; while (keyptr) { if (keyptr->name) { char *s = line; sprintf(s, "%s %s [%s@%s:%d] [hash#%d,nest=%d] '%s'", pfx,TIMESTR(tid),FFL, j,nestlevel,keyptr->name); s += strlen(s); PRINT_CALLS(); PRINT_HWM(); PRINT_RSS(); PRINT_STK(); PRINT_PAG(); PRINT_WALL(); PRINT_CPU(); *s = 0; DrHookPrint(*ftnunitno, line); } keyptr = keyptr->next; nestlevel++; } /* while (keyptr) */ } /* for (j=0; j 1) { if (*print_option == 2) { /* I'm not a master thread, but my master has the beginning of the calltree */ int initlev = 0; const int master = 1; first_time = 0; c_drhook_print_(ftnunitno, &master, print_option, &initlev); *level += initlev; } else if (tid > opt_timeline_thread) { return; } } if (abs_print_option == 7) { treeptr = NULL; } else if (abs_print_option == 5 || abs_print_option == 6) { treeptr = thiscall[tid-1]; } else { treeptr = calltree[tid-1]; } while (abs_print_option == 7 || (treeptr && treeptr->active)) { int do_print = (*print_option == 2 || abs_print_option == 7 || abs_print_option == 5 || abs_print_option == 6); if (do_print) { drhook_key_t *keyptr = (abs_print_option == 7) ? NULL : treeptr->keyptr; char *s = line; char is_timeline = 1, kind; switch (*print_option) { case -5: kind = '<'; break; case -6: kind = '-'; break; case -7: kind = 'E'; break; case 5: kind = '>'; break; case 6: kind = '+'; break; case 7: kind = 'B'; break; default: case 2: kind = ':'; is_timeline = 0; break; } if (*print_option == 2 || (is_timeline && tid > 1 && tid <= opt_timeline_thread)) { sprintf(s,"%s %s [DrHookCallTree] %s%c ", pfx,TIMESTR(tid), is_timeline ? "tl:" : "", kind); } else if (is_timeline && opt_timeline_thread == 1 && tid == 1) { sprintf(s,"%s %s [%s@%s:%d] %s%c ", pfx,TIMESTR(tid),FFL, is_timeline ? "tl:" : "", kind); } s += strlen(s); (*level)++; for (j=0; j<(*level); j++) *s++ = ' '; if (*print_option == 2) { if(mytid != tid) { /* We are printing the master call tree as far as >OMP*/ if(strncmp(">OMP",keyptr->name,4) == 0) { (*level)--; return; } } sprintf(s,"%s ",keyptr->name); s += strlen(s); } if (is_timeline) { double wall = WALLTIME(); double rss, curheap, stack, vmpeak; drhook_timeline_t *tl = &timeline[tid-1]; if (abs_print_option == 5 || abs_print_option == 6) { /* when called via drhook_begin/_end or memcounter */ curheap = tl->last_curheap_MB; rss = tl->last_rss_MB; stack = tl->last_stack_MB; vmpeak = tl->last_vmpeak_MB; } else { rss = (double)(getrss_()/1048576.0); /* in MBytes */ curheap = (opt_timeline_thread == 1 && tid == 1) ? (double)(getcurheap_()/1048576.0) : (double)(getcurheap_thread_(&tid)/1048576.0); /* in MBytes */ stack = (double)(getstk_()/1048576.0); /* in MBytes */ vmpeak = (double)(getvmpeak_()/1048576.0); /* in MBytes */ tl->last_curheap_MB = curheap; tl->last_rss_MB = rss; tl->last_stack_MB = stack; tl->last_vmpeak_MB = vmpeak; } if (opt_timeline_format == 1) { sprintf(s, "%.6f %.4g %.4g %.4g %.4g", wall, rss, curheap, stack, vmpeak); } else { sprintf(s, "wall=%.6f cpu=%.4g hwm=%.4g rss=%.4g curheap=%.4g stack=%.4g vmpeak=%.4g pag=%lld", wall, CPUTIME(), (double)(gethwm_()/1048576.0), rss, curheap, (double)(getstk_()/1048576.0), (double)(getvmpeak_()/1048576.0), getpag_()); } s += strlen(s); *s++ = ' '; if (keyptr) { sprintf(s,"'%s'",keyptr->name); } else { sprintf(s,"'#PROGRAM %s'",(*print_option == 7) ? "BEGIN" : "END"); } s += strlen(s); { int current_numth = drhook_oml_get_num_threads(); sprintf(s,"[#%d]",current_numth); s += strlen(s); } } else { PRINT_CALLS(); PRINT_HWM(); PRINT_RSS(); PRINT_STK(); PRINT_PAG(); PRINT_WALL(); PRINT_CPU(); } *s = 0; DrHookPrint(*ftnunitno, line); } if (abs_print_option == 7 || abs_print_option == 5 || abs_print_option == 6) break; if (treeptr) treeptr = treeptr->next; } /* while (abs_print_option == 7 || (treeptr && treeptr->active)) */ } else if (*print_option == 3) { /* profiling (CPU or wall-clock) */ int len; int t; double cumul; double tottime = 0, max_overhead_pc = 0; double *tot = NULL; long long int *cycles = NULL; int nprof = 0; drhook_prof_t *prof = NULL; drhook_prof_t *p; double *flop = NULL, *instr = NULL; if (!opt_wallprof && !opt_cpuprof) return; /* no profiling info available */ if (tid > 1) return; /* just master thread allowed ; takes care of siblings, too */ if (numthreads<=0) return; if (do_prof_off) return; do_prof_off = 1; /* Insert "$drhook" */ if (keyself && opt_self > 1) { for (t=0; tname && (keyptr->status == 0 || signal_handler_called)) { double self; if (opt_wallprof) { self = keyptr->delta_wall_all - keyptr->delta_wall_child; } else { self = keyptr->delta_cpu_all - keyptr->delta_cpu_child; } /* if (self < 0) self = 0; */ tot[t] += self; if (opt_cycles) { long long int self_cycles = keyptr->delta_cycles_all - keyptr->delta_cycles_child; cycles[t] += self_cycles; } nprof++; } keyptr = keyptr->next; } /* while (keyptr && keyptr->status == 0) */ } /* for (t=0; t 1) ? keyself[0]->delta_wall_all : 0); for (t=1; t 1) ? keyself[t]->delta_wall_all : 0); tottime = MAX(tottime,tmp); } } else { /* ok & reliable (for cpuprof) */ tottime = 0; for (t=0; t 1) ? keyself[t]->delta_cpu_all : 0)); } if (tottime <= 0) tottime = 1e-10; p = prof = calloc_drhook(nprof + 1, sizeof(*prof)); /* Make sure there is at least one entry */ for (t=0; tname && (keyptr->status == 0 || signal_handler_called)) { #if defined(DR_HOOK_HAVE_PAPI) /* No point slowing down this code with an if (opt_papi) * as it can be called by signal_drhook(). This would just be * processing zeros anyway as we only use calloc() for keys */ drhook_papi_subtract(p->counter_self, keyptr->delta_counters_all, keyptr->delta_counters_child ); drhook_papi_cpy(p->counter_tot, keyptr->delta_counters_all); #endif p->self = opt_wallprof ? keyptr->delta_wall_all - keyptr->delta_wall_child : keyptr->delta_cpu_all - keyptr->delta_cpu_child; p->total = opt_wallprof ? keyptr->delta_wall_all : keyptr->delta_cpu_all; p->calls = keyptr->calls; p->name = keyptr->name; p->pc = (p->self/tottime) * 100.0; if (p->calls > 0) { p->percall_ms_self = (p->self/p->calls) * 1000.0; p->percall_ms_total = (p->total/p->calls) * 1000.0; } p->tid = t+1; p->index = p - prof; p->filename = keyptr->filename; p->sizeinfo = keyptr->sizeinfo; p->min_sizeinfo = keyptr->min_sizeinfo; p->max_sizeinfo = keyptr->max_sizeinfo; p->sizespeed = (p->self > 0 && p->sizeinfo > 0) ? p->sizeinfo/p->self : 0; p->sizeavg = (p->calls > 0 && p->sizeinfo > 0) ? p->sizeinfo/p->calls : 0; p->callpath = keyptr->callpath; p->callpath_len = keyptr->callpath_len; p++; } keyptr = keyptr->next; } /* while (keyptr && keyptr->status == 0) */ } /* for (j=0; jself; p->maxval = &maxval[cluster]; clusize[cluster] = 1; prevname = p->name; p++; for (j=1; jname)) { (p-1)->cluster = cluster; (p-1)->maxval = &maxval[cluster]; prevname = p->name; cluster++; } if (p->self > maxval[cluster]) maxval[cluster] = p->self; p->cluster = cluster; p->maxval = &maxval[cluster]; clusize[cluster]++; p++; } /* for (j=1; j 0) ? (cluster + 1) : 0; /* Active no. of routines */ if (opt_wallprof) tottime = 0; p = prof; for (j=0; jcluster; if (clusize[cluster] > 1) { /* multiple threads <= numthreads indeed called this routine */ p->is_max = (p->self == *p->maxval); if (p->is_max) { /* first max found will be used for total time */ clusize[cluster] = -clusize[cluster]; /* ensures that max has been found for this cluster */ use_this = opt_wallprof; } } else if (clusize[cluster] == 1) { use_this = opt_wallprof; } if (use_this && opt_wallprof) tottime += p->self; p++; } if (tottime <= 0) tottime = 1e-10; if (opt_wallprof) { /* use re-calculated tottime to define percentages */ p = prof; for (j=0; jpc = (p->self/tottime) * 100.0; p++; } } /* sorting with respect to percentage value */ p = prof; qsort(p, nprof, sizeof(*p), prof_pc_comp_desc); max_overhead_pc = 0; for (t=0; t 0) { max_overhead_pc = 100.0*(max_overhead_pc/(tottime - max_overhead_pc)); } else { max_overhead_pc = 100; } fprintf(fp, "Profiling information for program='%s', proc#%d:\n",a_out, myproc); fprintf(fp,"\tNo. of instrumented routines called : %d\n", numroutines); fprintf(fp,"\tInstrumentation started : %s\n",start_stamp ? start_stamp : "N/A"); end_stamp = timestamp(); fprintf(fp,"\tInstrumentation ended : %s\n",end_stamp ? end_stamp : "N/A"); fprintf(fp,"\tInstrumentation overhead: %.2f%%\n",max_overhead_pc); { long long int hwm = getmaxhwm_()/1048576; long long int rss = getmaxrss_()/1048576; long long int maxstack = getmaxstk_()/1048576; long long int vmpeak = getvmpeak_()/1048576; long long int pag = getpag_(); fprintf(fp, "\tMemory usage : %lld MB (heap), %lld MB (rss), %lld MB (stack), %lld MB (vmpeak), %lld (paging)\n", hwm,rss,maxstack,vmpeak,pag); fprintf(fp, "\t%s-time is %.2f sec on proc#%d (%d procs, %d threads)\n", opt_wallprof ? "Wall" : "Total CPU", tottime, myproc, nproc, numthreads); } if (myproc == 1) { fprintf(stderr, "Profiling information for program='%s', proc#%d:\n",a_out, myproc); fprintf(stderr,"\tNo. of instrumented routines called : %d\n", numroutines); fprintf(stderr,"\tInstrumentation started : %s\n",start_stamp ? start_stamp : "N/A"); fprintf(stderr,"\tInstrumentation ended : %s\n",end_stamp ? end_stamp : "N/A"); fprintf(stderr,"\tInstrumentation overhead: %.2f%%\n",max_overhead_pc); fprintf(stderr, "\t%s-time is %.2f sec on proc#%d (%d procs, %d threads)\n", opt_wallprof ? "Wall" : "Total CPU", tottime, myproc, nproc, numthreads); } /* if (myproc == 1) */ free_drhook(end_stamp); if (thread_cycles) { int ntids = numthreads; if (ntids > 1) { extern void drhook_run_omp_parallel_get_cycles_(const int *, long long int *); drhook_run_omp_parallel_get_cycles_(&ntids,thread_cycles); } else { long long int cycles = ec_get_cycles(); thread_cycles[0] = cycles - thread_cycles[0]; } } // if (thread_cycles) for (t=0; t"); if (opt_clusterinfo) fprintf(fp, " [Cluster:(id,size)]"); fprintf(fp, "\n"); if (opt_sizeinfo) fprintf(fp, "%*s %s\n",len-20," ","(Size; Size/sec; Size/call; MinSize; MaxSize)"); fprintf(fp, " (self) (sec) (sec) (sec) ms/call ms/call\n"); fprintf(fp, "\n"); cumul = 0; for (j=0; jcluster]; if (p->pc < percent_limit) break; if (opt_cputime) { cumul += p->self; } else { if (p->is_max || cluster_size == 1) cumul += p->self; } { fprintf(fp, fmt, ++j, p->pc, cumul, p->self, p->total, p->calls, p->percall_ms_self, p->percall_ms_total, p->is_max ? "*" : " "); } print_routine_name(fp, p, len, cluster_size); if (opt_sizeinfo && p->sizeinfo > 0) { char s1[DRHOOK_STRBUF], s2[DRHOOK_STRBUF], s3[DRHOOK_STRBUF]; char s4[DRHOOK_STRBUF], s5[DRHOOK_STRBUF]; lld_commie(p->sizeinfo,s1); dbl_commie(p->sizespeed,s2); dbl_commie(p->sizeavg,s3); lld_commie(p->min_sizeinfo,s4); lld_commie(p->max_sizeinfo,s5); fprintf(fp,"\n%*s (%s; %s; %s; %s; %s)",len-20," ",s1,s2,s3,s4,s5); } fprintf(fp,"\n"); p++; } /* for (j=0; jcluster]; if (opt_cputime) cumul += p->self; else if (p->is_max || cluster_size == 1) cumul += p->self; { fprintf(fpcsv, csvfmt, p->name, myproc-1, p->tid-1, ++j, p->pc, cumul, p->self, p->total, p->calls, p->is_max ? "*" : " " ); for (int c=0;ccounter_self[c]); for (int c=0;ccounter_tot[c]); if (first_counter_is_cyc==1) fprintf(fpcsv,",%.3f,%.3f", p->counter_self[0]/p->self/1000000.0, p->counter_tot[0]/p->total/1000000.0 ); } fprintf(fpcsv, "\n"); p++; } /* for (j=0; j 1) return; /* just master thread allowed ; takes care of siblings, too */ if (numthreads<=0) return; if (do_prof_off) return; do_prof_off = 1; tot = calloc_drhook(numthreads, sizeof(*tot)); maxseen_tot = calloc_drhook(numthreads, sizeof(*maxseen_tot)); for (t=0; tname && (keyptr->status == 0 || signal_handler_called)) { long long int self; self = keyptr->maxmem_selfdelta; if (self < 0) self = 0; tot[t] += self; maxseen_tot[t] = MAX(maxseen_tot[t], keyptr->mem_seenmax); nprof++; } keyptr = keyptr->next; } /* while (keyptr && keyptr->status == 0) */ } /* for (t=0; tname && (keyptr->status == 0 || signal_handler_called)) { p->self = keyptr->maxmem_selfdelta; p->children = keyptr->mem_child; p->hwm = keyptr->mem_maxhwm; p->rss = keyptr->mem_maxrss; p->stk = keyptr->mem_maxstk; p->pag = keyptr->mem_maxpagdelta; p->leaked = keyptr->mem_curdelta; p->calls = keyptr->calls; p->alloc_count += keyptr->alloc_count; p->free_count += keyptr->free_count; p->name = keyptr->name; p->pc = (p->self/totmaxmem_delta) * 100.0; p->tid = t+1; p->index = p - prof; p->filename = keyptr->filename; p->callpath = keyptr->callpath; p->callpath_len = keyptr->callpath_len; p++; } keyptr = keyptr->next; } /* while (keyptr && keyptr->status == 0) */ } /* for (t=0; tself; p->maxval = &maxval[cluster]; clusize[cluster] = 1; prevname = p->name; p++; for (j=1; jname)) { (p-1)->cluster = cluster; (p-1)->maxval = &maxval[cluster]; prevname = p->name; cluster++; } if (p->self > maxval[cluster]) maxval[cluster] = p->self; p->cluster = cluster; p->maxval = &maxval[cluster]; clusize[cluster]++; p++; } /* for (j=1; j 0) ? (cluster + 1) : 0; /* Active no. of routines */ totmaxmem_delta = 0; p = prof; for (j=0; jcluster; if (clusize[cluster] > 1) { /* multiple threads <= numthreads indeed called this routine */ p->is_max = (p->self == *p->maxval); if (p->is_max) { /* first max found will be used for total time */ clusize[cluster] = -clusize[cluster]; /* ensures that max has been found for this cluster */ use_this = 1; } } else if (clusize[cluster] == 1) { use_this = 1; } if (use_this) totmaxmem_delta += p->self; p++; } if (totmaxmem_delta <= 0) totmaxmem_delta = 1e-10; /* To avoid divide-by-zero */ /* use re-calculated totmaxmem_delta to define percentages */ p = prof; for (j=0; jpc = (p->self/totmaxmem_delta) * 100.0; p++; } /* sorting with respect to percentage value */ p = prof; qsort(p, nprof, sizeof(*p), memprof_pc_comp_desc); fprintf(fp, "Memory-profiling information for program='%s', proc#%d:\n",a_out, myproc); fprintf(fp,"\tNo. of instrumented routines called : %d\n", numroutines); fprintf(fp,"\tInstrumentation started : %s\n",start_stamp ? start_stamp : "N/A"); end_stamp = timestamp(); fprintf(fp,"\tInstrumentation ended : %s\n",end_stamp ? end_stamp : "N/A"); { long long int hwm = gethwm_()/1048576; long long int rss = getrss_()/1048576; long long int maxstack = getmaxstk_()/1048576; long long int vmpeak = getvmpeak_()/1048576; long long int pag = getpag_(); long long int maxseen = 0; long long int leaked = 0; p = prof; for (j=0; jleaked > 0) leaked += p->leaked; p++; } for (t=0; t"); if (opt_clusterinfo) fprintf(fp," [Cluster:(id,size)]"); fprintf(fp,"\n"); fprintf(fp, " (self) (bytes) (bytes) (bytes) (bytes) (bytes) (delta)"); /*"12345-1234567899-12345678901234-12345678901234-12345678901234-12345678901234-12345678901234-12345678901234-12345678901234-123456789012-123456789012"*/ fprintf(fp,"\n"); p = prof; for (j=0; jcluster]; if (p->pc < percent_limit) break; t = p->tid - 1; if (p->children > maxseen_tot[t]) p->children = maxseen_tot[t]; /* adjust */ fprintf(fp, fmt, ++j, p->pc, p->self, p->children, p->leaked, p->hwm, p->stk, p->pag, p->calls, p->alloc_count, (p->alloc_count - p->free_count != 0) ? "*" : " ", p->free_count, p->is_max ? "*" : " "); print_routine_name(fp, p, len, cluster_size); fprintf(fp,"\n"); p++; } /* for (j=0; j 0 ? name_len : (int)strlen(name), filename_len > 0 ? filename_len : (int)strlen(filename)); } else if (option == 1) { c_drhook_end_(name, &tid, handle, filename, &sizeinfo, name_len > 0 ? name_len : (int)strlen(name), filename_len > 0 ? filename_len : (int)strlen(filename)); } } /* this is result of moving some code from libodb.a (odb/aux/util_ccode.c) for use by libifsaux.a directly ; simplifies linking sequences. */ /* Portable CPU-timer (User + Sys) ; also WALL CLOCK-timer */ #include #include #include #undef MIN #undef MAX #include #include double util_walltime_() { static double time_init = -1; double time_in_secs; double key = 0; #if defined(CLOCK_BOOTTIME) struct timespec tv; if (clock_gettime(CLOCK_BOOTTIME,&tv) == 0) { key = (double) tv.tv_sec + (double) tv.tv_nsec / 1000000000; } #elif defined(CLOCK_MONOTONIC) struct timespec tv; if (clock_gettime(CLOCK_MONOTONIC,&tv) == 0) { key = (double) tv.tv_sec + (double) tv.tv_nsec / 1000000000; } #else struct timeval tv; if (gettimeofday(&tv, NULL) == 0) { key = (double) tv.tv_sec + (double) tv.tv_usec / 1000000; } #endif if (time_init == -1) time_init = key; // first time time_in_secs = key - time_init; return time_in_secs; } extern clock_t times (struct tms *buffer); double util_cputime_() { struct tms tbuf; static int first_time = 1; static double clock_ticks = 0; (void) times(&tbuf); if (first_time) { clock_ticks = (double) sysconf(_SC_CLK_TCK); first_time = 0; } return (tbuf.tms_utime + tbuf.tms_stime + tbuf.tms_cutime + tbuf.tms_cstime) / clock_ticks; } int util_ihpstat_(int *option) { int ret_value = 0; return ret_value; } #ifdef _DRHOOK_TIMER_T_ static void set_timed_kill() { if (drhook_timed_kill) { const char delim[] = ", \t/"; char *p, *s = strdup_drhook(drhook_timed_kill); p = strtok(s,delim); while (p) { int target_myproc, target_omltid, target_sig; double start_time; int nelems = sscanf(p,"%d:%d:%d:%lf", &target_myproc, &target_omltid, &target_sig, &start_time); int ntids = drhook_oml_get_max_threads(); if (nelems == 4 && (target_myproc == myproc || target_myproc == -1) && (target_omltid == -1 || (target_omltid >= 1 && target_omltid <= ntids)) && (target_sig >= 1 && target_sig <= NSIG) && start_time > 0) { if (ntids > 1) { extern void drhook_run_omp_parallel_ipfipipipdpstr_(const int *, void (*func)(const int *, const int *, const int *, const double *, const char *, long), const int *, const int *, const int *, const double *, const char *, long); drhook_run_omp_parallel_ipfipipipdpstr_(&ntids,set_killer_timer, &ntids,&target_omltid,&target_sig,&start_time,p,strlen(p)); } else { set_killer_timer(&ntids,&target_omltid,&target_sig,&start_time,p,strlen(p)); } } p = strtok(NULL,delim); } free_drhook(s); } } #else static void set_timed_kill() { // Definition of timer_t, timer_create, timer_set // is a POSIX extention, not available on e.g. Darwin } #endif void drhook_calltree() { if ( drhook_lhook ) { int ftnunitno = 0; int tid = 0; int print_option = 2; int level = 99; c_drhook_print_(&ftnunitno, &tid, &print_option, &level); } } int drhook_active() { return drhook_lhook; } void drhook_init(int argc, char* argv[]) { // Initialization workflow here: // drhook_init(argc,argv) -- sets up command-line args // cdrhookinit_ -- C-Interface to Fortran "DR_HOOK_INIT" // dr_hook_init_ -- Initialises DR_HOOK from Fortran // c_drhook_init_ -- Fortran interface to init_drhook // init_drhook -- [sets drhook_lhook=1] extern void *cdrhookinit_(int *lhook); /* from ifsaux/support/cdrhookinit.F90 */ static int first_time = 1; if (first_time) { /* Not thread safe */ if( argc ) { ec_args(argc, argv); } cdrhookinit_(&drhook_lhook); first_time = 0; } } fiat-ecmwf-2.0.0/src/fiat/drhook/extensions/0000775000175000017500000000000015157200431021114 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/drhook/extensions/nvtx/0000775000175000017500000000000015157200431022113 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/drhook/extensions/nvtx/dr_hook_nvtx.c0000664000175000017500000000316315157200431024766 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * (C) Copyright 2024- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #if HAVE_NVTX3 #include #else #include #endif #include #include #include "dr_hook_nvtx.h" static uint32_t adler32 (const unsigned char *data) { const uint32_t MOD_ADLER = 65521; uint32_t a = 1, b = 0; size_t index; for (index = 0; data[index] != 0; ++index) { a = (a + data[index]*2) % MOD_ADLER; b = (b + a) % MOD_ADLER; } return (b << 16) | a; } void dr_hook_nvtx_start (const char * name) { int hash = 0; int color_id = adler32 ((const unsigned char*)name); int r,g,b; r=color_id & 0x000000ff; g=(color_id & 0x000ff000) >> 12; b=(color_id & 0x0ff00000) >> 20; if (r<64 & g<64 & b<64) { r=r*3; g=g*3+64; b=b*4; } color_id = 0xff000000 | (r << 16) | (g << 8) | (b); nvtxEventAttributes_t eventAttrib = {0}; eventAttrib.version = NVTX_VERSION; eventAttrib.size = NVTX_EVENT_ATTRIB_STRUCT_SIZE; eventAttrib.colorType = NVTX_COLOR_ARGB; eventAttrib.color = color_id; eventAttrib.messageType = NVTX_MESSAGE_TYPE_ASCII; eventAttrib.message.ascii = name; nvtxRangePushEx (&eventAttrib); } void dr_hook_nvtx_end () { nvtxRangePop (); } fiat-ecmwf-2.0.0/src/fiat/drhook/extensions/nvtx/dr_hook_nvtx.h0000664000175000017500000000111215157200431024763 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef FIAT_DRHOOK_NVTX_DR_HOOK_NVTX_H #define FIAT_DRHOOK_NVTX_DR_HOOK_NVTX_H void dr_hook_nvtx_start (const char* name); void dr_hook_nvtx_end (); #endif //FIAT_DRHOOK_NVTX_DR_HOOK_NVTX_H fiat-ecmwf-2.0.0/src/fiat/drhook/extensions/papi/0000775000175000017500000000000015157200431022045 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/drhook/extensions/papi/drhook_papi.c0000664000175000017500000002476415157200431024525 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include "drhook_papi.h" #include #include #include #include #include "oml.h" #define STD_MSG_LEN 4096 static int silent = 0; int* drhook_papi_event_set=NULL; enum { drhook_papi_notstarted, drhook_papi_running, drhook_papi_failed }; int drhook_papi_state=drhook_papi_notstarted; int drhook_papi_rank=0; /* C style! */ static int papi_counter_event_codes[MAXNPAPICNTRS]; static const char* papi_counter_names[MAXNPAPICNTRS]; static int papi_counters_count = 0; /* function to use for thread id - it should be better than omp_get_thread_num! */ unsigned long papi_safe_thread_num(){ return oml_my_thread()-1; } int drhook_papi_max_num_counters() { return MAXNPAPICNTRS; } int drhook_papi_max_name_len() { return PAPI_MAX_STR_LEN; } void drhook_papi_counter_name(int c, char* event_name){ PAPI_event_code_to_name(papi_counter_event_codes[c], event_name); } void drhook_papi_cpy(long_long* a,long_long* b){ for (int i=0;i0){ char fmt[STD_MSG_LEN]; sprintf(fmt,"%%%lds",strlen(s)); sprintf(msg,fmt," "); for (int i=0;i 0) { snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, library version mismatch between compilation and run!\n"); fprintf(stderr, "%s\n",pmsg); return 0; } if (paperr == PAPI_EINVAL){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, PAPI_EINVAL\n"); fprintf(stderr, "%s\n",pmsg); return 0; } if (paperr == PAPI_ENOMEM){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, PAPI_ENOMEM\n"); fprintf(stderr, "%s\n",pmsg); return 0; } if (paperr == PAPI_ESBSTR){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, PAPI_ESBSTR\n"); fprintf(stderr, "%s\n",pmsg); return 0; } if (paperr == PAPI_ESYS){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, PAPI_ESYS\n"); fprintf(stderr, "%s\n",pmsg); return 0; } else { snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, unknown error code: %d\n", paperr); fprintf(stderr, "%s\n",pmsg); return 0; } } lib_version = PAPI_get_opt( PAPI_LIB_VERSION, NULL ); int nthreads=oml_get_max_threads(); paperr=PAPI_thread_init(papi_safe_thread_num); if( paperr != PAPI_OK ) { snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, thread init failed (%s)",PAPI_strerror(paperr)); fprintf(stderr, "%s\n",pmsg); return 0; } snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Version %d.%d.%d initialised with %d threads", PAPI_VERSION_MAJOR( lib_version ), PAPI_VERSION_MINOR( lib_version ), PAPI_VERSION_REVISION( lib_version ), nthreads); if (drhook_papi_rank==0 && !silent) { fprintf(stderr, "%s\n",pmsg); } drhook_papi_event_set=malloc_drhook(nthreads*sizeof(int)); int rcout; drhook_run_omp_parallel_papi_startup(drhook_papi_event_set, nthreads, &rcout); if (rcout) { return 0; } for (int i=0; i < drhook_papi_max_num_counters(); i++) { free((void *) papi_counter_names[i]); } drhook_papi_state=drhook_papi_running; if (drhook_papi_rank==0 && !silent) { fprintf(stderr, "DRHOOK:PAPI: Initialisation sucess\n"); } return 1; } int drhook_papi_start_threads(int* events){ int thread=papi_safe_thread_num(); int papiErr; char pmsg[STD_MSG_LEN]; events[thread]=PAPI_NULL; papiErr=PAPI_create_eventset(&events[thread]); if (papiErr != PAPI_OK){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, create event set failed (%s) \n",PAPI_strerror(papiErr)); fprintf(stderr, "%s\n",pmsg); return 0; } if (!silent) fprintf(stderr, "DRHOOK:PAPI: Event set %d created for thread %d\n",events[thread],thread); if (!silent && drhook_papi_rank==0 && thread==0) fprintf(stderr, "DRHOOK:PAPI: Attempting to add events to event set:\n"); for (int counter=0; counter < drhook_papi_num_counters(); counter ++) { int eventCode; if (!silent && drhook_papi_rank==0 && thread==0) { snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: %s", papi_counter_names[counter]); fprintf(stderr, "%s\n",pmsg); } papiErr=PAPI_event_name_to_code(papi_counter_names[counter], &eventCode); if (papiErr != PAPI_OK){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, event name to code failed for %s (%s)", papi_counter_names[counter], PAPI_strerror(papiErr)); fprintf(stderr, "%s\n",pmsg); PAPI_perror("initPapi"); return 0; } papi_counter_event_codes[counter] = eventCode; papiErr=PAPI_add_event(events[thread],eventCode); if (papiErr!=PAPI_OK){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error, add_event failed: %d (%s)",papiErr,PAPI_strerror(papiErr)); fprintf(stderr, "%s\n",pmsg); if (papiErr == PAPI_EINVAL) { fprintf(stderr, "Invalid argument. "); } else if (papiErr == PAPI_ENOMEM) { fprintf(stderr, "Out of memory. "); } else if (papiErr == PAPI_ENOEVST) { fprintf(stderr, "EventSet does not exist. "); } else if (papiErr == PAPI_EISRUN) { fprintf(stderr, "EventSet is running. "); } else if (papiErr == PAPI_ECNFLCT) { fprintf(stderr, "Conflict. "); } else if (papiErr == PAPI_ENOEVNT) { fprintf(stderr, "Preset not available. "); } fprintf(stderr, "This is an error within PAPI and not DrHook. DrHook is only reporting the error it received.\n"); return 0; } else { #if defined(DEBUG) snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Added code=%d to Event set %d",eventCode, events[thread]); if (thread==0) { fprintf(stderr, "%s\n",pmsg); } #endif } } int number = drhook_papi_num_counters(); int* checkEvents=malloc(drhook_papi_num_counters()*sizeof(int)); papiErr = PAPI_list_events(events[thread], checkEvents, &number); if (papiErr != PAPI_OK){ snprintf(pmsg,STD_MSG_LEN,"DRHOOK:PAPI: Error querying events - %d=%s",papiErr,PAPI_strerror(papiErr)); fprintf(stderr, "%s\n",pmsg); return 0; } #if defined(DEBUG) for (int counter=0;counter #define MAXNPAPICNTRS 4 int drhook_papi_init(int rank); int drhook_papi_num_counters(); int drhook_papi_max_num_counters(); int drhook_papi_max_name_len(); void drhook_papi_counter_name(int c, char* event_name); void drhook_papi_add_counter_name(const char* counter_name); long_long drhook_papi_read(int counterId); int drhook_papi_readAll(long_long* counterArray); /* implemented in fortran */ int drhook_run_omp_parallel_papi_startup(int* drhook_papi_event_set, int nthreads, int* rcout); /* a = b - c if b or c == NULL means use current readings */ void drhook_papi_subtract(long_long* a, long_long* b, long_long* c); /* a = b + c if a==NULL, b=b+c */ void drhook_papi_add(long_long* a, long_long* b, long_long* c); /* a = b */ void drhook_papi_cpy(long_long* a, long_long* b); /* a=0 */ void drhook_papi_bzero(long_long* a); void drhook_papi_print(char* s, long_long* a, int header); #endif fiat-ecmwf-2.0.0/src/fiat/drhook/extensions/roctx/0000775000175000017500000000000015157200431022253 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/drhook/extensions/roctx/dr_hook_roctx.c0000664000175000017500000000126015157200431025262 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * (C) Copyright 2024- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #if HAVE_ROCPROFILER_SDK_ROCTX #include #else #include #endif #include "dr_hook_roctx.h" void dr_hook_roctx_start (const char * name) { roctxRangePush(name); } void dr_hook_roctx_end () { roctxRangePop (); } fiat-ecmwf-2.0.0/src/fiat/drhook/extensions/roctx/dr_hook_roctx.h0000664000175000017500000000112215157200431025264 0ustar alastairalastair/* * (C) Copyright 2024- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef FIAT_DRHOOK_ROCTX_DR_HOOK_ROCTX_H #define FIAT_DRHOOK_ROCTX_DR_HOOK_ROCTX_H void dr_hook_roctx_start (const char* name); void dr_hook_roctx_end (); #endif //FIAT_DRHOOK_ROCTX_DR_HOOK_ROCTX_H fiat-ecmwf-2.0.0/src/fiat/drhook/dr_hook_init.F900000664000175000017500000001025315157200431021646 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! #define DR_HOOK_ASSERT_MPI_INITITALIZED 1 !! TEMPORARY !! !! DR_HOOK will abort when MPI is not initialized. !! DR_HOOK used to initialize MPI via MPL_INIT, but no longer. SUBROUTINE DR_HOOK_INIT() !! Initialises DR_HOOK !! Also calls !! - OML_INIT to e.g. save the OMP_NUM_THREADS environment variable !! - EC_ARGS to save command-line arguments in case the main program is Fortran !! Environment variable "DR_HOOK=1" will enable DR_HOOK USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INT USE OML_MOD ,ONLY : OML_MAX_THREADS, OML_INIT USE EC_ARGS_MOD ,ONLY : EC_ARGS USE YOMHOOK ,ONLY : LHOOK ! True by default IMPLICIT NONE LOGICAL,SAVE :: LL_FIRST_TIME = .TRUE. CHARACTER(LEN=512) :: CLENV INTEGER(KIND=C_INT) :: IMAX_THREADS IF (LL_FIRST_TIME) THEN LL_FIRST_TIME = .FALSE. CALL GET_ENVIRONMENT_VARIABLE('DR_HOOK',CLENV) IF ( CLENV == ' ' .OR. CLENV == '0' .OR. & & CLENV == 'false' .OR. CLENV == 'FALSE' .OR. & & CLENV == 'off' .OR. CLENV == 'OFF' .OR. & & CLENV == 'no' .OR. CLENV == 'NO' ) THEN LHOOK = .FALSE. ENDIF CALL OML_INIT() #if DR_HOOK_ASSERT_MPI_INITITALIZED CALL DR_HOOK_ASSERT_MPI_INITIALIZED_() #endif CALL EC_ARGS() IF (.NOT. LHOOK) RETURN IMAX_THREADS = OML_MAX_THREADS() CALL C_DRHOOK_INIT('',IMAX_THREADS) !! First argument (progname) is empty ==> c_drhook_init will retrieve progname via ec_args itself ENDIF CONTAINS #if DR_HOOK_ASSERT_MPI_INITITALIZED SUBROUTINE DR_HOOK_ASSERT_MPI_INITIALIZED_() LOGICAL :: LMPI_REQUIRED INTEGER :: ILEN INTEGER(KIND=C_INT) :: IERR LOGICAL :: LMPI_INITIALIZED INTEGER, PARAMETER :: NVARS = 4 CHARACTER(LEN=32), DIMENSION(NVARS) :: CMPIRUN_DETECT CHARACTER(LEN=4) :: CLENV_DR_HOOK_ASSERT_MPI_INITIALIZED INTEGER :: IVAR #include "mpif.h" #include "abor1.intfb.h" ! Environment variables that are set when mpirun, srun, aprun, ... are used (see eckit/mpi/Comm.cc) CMPIRUN_DETECT(1) = 'OMPI_COMM_WORLD_SIZE' ! OpenMPI CMPIRUN_DETECT(2) = 'ALPS_APP_PE' ! Cray PE CMPIRUN_DETECT(3) = 'PMI_SIZE' ! Intel CMPIRUN_DETECT(4) = 'SLURM_STEP_NUM_TASKS' ! Slurm ! When adding here, change NVARS parameter above LMPI_REQUIRED = .FALSE. DO IVAR=1,NVARS CALL GET_ENVIRONMENT_VARIABLE(NAME=TRIM(CMPIRUN_DETECT(IVAR)),LENGTH=ILEN) IF (ILEN > 0) THEN LMPI_REQUIRED = .TRUE. EXIT ! break ENDIF ENDDO IF (LMPI_REQUIRED) THEN CALL GET_ENVIRONMENT_VARIABLE(NAME="DR_HOOK_ASSERT_MPI_INITIALIZED", VALUE=CLENV) IF ( CLENV == '0' .OR. & & CLENV == 'false' .OR. CLENV == 'FALSE' .OR. & & CLENV == 'off' .OR. CLENV == 'OFF' .OR. & & CLENV == 'no' .OR. CLENV == 'NO' ) THEN LMPI_REQUIRED = .FALSE. ENDIF CALL GET_ENVIRONMENT_VARIABLE(NAME="DR_HOOK_NOT_MPI", VALUE=CLENV) IF ( CLENV == '1' .OR. & & CLENV == 'true' .OR. CLENV == 'TRUE' .OR. & & CLENV == 'on' .OR. CLENV == 'ON' .OR. & & CLENV == 'yes' .OR. CLENV == 'YES' ) THEN LMPI_REQUIRED = .FALSE. ENDIF ENDIF IF (LMPI_REQUIRED) THEN #ifdef NO_MPI_SUPPORT CALL ABOR1FL( "dr_hook_init.F90", __LINE__, & & "Application is requesting MPI, but FIAT compiled *without* MPI support" ) #endif CALL MPI_INITIALIZED(LMPI_INITIALIZED,IERR) IF( IERR /= 0 ) THEN CALL ABOR1FL( "dr_hook_init.F90", __LINE__, & & "DR_HOOK: MPI_INITIALIZED failed" ) ENDIF IF( .NOT.LMPI_INITIALIZED ) THEN CALL ABOR1FL( "dr_hook_init.F90", __LINE__, & & "DR_HOOK no longer calls MPL_INIT. Please initialize MPI (or MPL) before first DR_HOOK call."//NEW_LINE('A')//& & "This assertion can be disabled with environment: DR_HOOK_ASSERT_MPI_INITIALIZED=0" ) ENDIF ENDIF END SUBROUTINE #endif END SUBROUTINE fiat-ecmwf-2.0.0/src/fiat/system/0000775000175000017500000000000015157200431016753 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/system/internal/0000775000175000017500000000000015157200431020567 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/system/internal/gentrbk.F900000664000175000017500000000265515157200431022513 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! !-- Generic traceback calls here SUBROUTINE GENTRBK_DUMMY END SUBROUTINE GENTRBK_DUMMY SUBROUTINE INTEL_TRBK() #ifdef __INTEL_COMPILER USE IFCORE #endif USE MPL_DATA_MODULE, ONLY : MPL_RANK LOGICAL :: DONE_TRACEBACK = .FALSE. INTEGER :: MYPROC,MYTHREAD CHARACTER(LEN=512) :: CLTRBK CHARACTER(LEN=512) :: MESSAGE #ifdef _OPENMP INTEGER,EXTERNAL :: OMP_GET_THREAD_NUM #endif IF(DONE_TRACEBACK) THEN WRITE(0,*) "INTEL_TRBK already called" RETURN ENDIF MYPROC=MPL_RANK #ifdef _OPENMP MYTHREAD=OMP_GET_THREAD_NUM() + 1 #else MYTHREAD=1 #endif #ifdef __INTEL_COMPILER WRITE(MESSAGE,'(A,I4,A,I2,A)') & & "Process ",MYPROC," thread ",MYTHREAD, & & " calling tracebackqq from intel_trbk()" CALL TRACEBACKQQ(TRIM(MESSAGE), USER_EXIT_CODE=-1) CALL GET_ENVIRONMENT_VARIABLE("EC_LINUX_TRBK",CLTRBK) #else CLTRBK = '1' #endif IF( CLTRBK == '1' ) THEN WRITE(0,*) "Process ",MYPROC," thread ",MYTHREAD, & & " calling linux_trbk from intel_trbk()" CALL LINUX_TRBK() ! See linuxtrbk.c ENDIF DONE_TRACEBACK=.TRUE. END SUBROUTINE INTEL_TRBK fiat-ecmwf-2.0.0/src/fiat/system/internal/memory_hook.c0000664000175000017500000000703615157200431023271 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include /* * * Philippe Marguinaud, Meteo-France * */ #if defined(LINUX) #if defined(__PGIC__) && defined(__PGIC_MINOR__) #if __PGIC__ <= 20 && __PGIC_MINOR__ < 7 #define SKIP_MEMORY_HOOK #endif #endif #if defined(SKIP_MEMORY_HOOK) #warning PGI/NVHPC (tested up to 19.4) does not support __sync_fetch_and_add, skipping memory_hook /* * Comments/Modifications by Willem Deconinck, ECMWF * Problem with PGI tested up to 19.4: undefined symbol __sync_fetch_and_add * Test with NVHPC 20.7 works, unsure about versions between 19.4 and 20.7 * * --> Is this not GNU specific rather than LINUX? * + C11 has new standard API available in , * but PGI/19.4 does not yet support it. */ #else static size_t align = 0; /* Must be a multiple of sizeof (void) */ static unsigned char snan8[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf4, 0x7f }; static unsigned char cinit[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; static unsigned char zero0[] = { 0x00 }; static unsigned char * init = NULL; static int sizeof_init = 0; static int count = -1; void * __wrap_malloc (size_t size, const void *caller) { void * ptr; int _align = align > 0 ? align : sizeof (void*); int c; if ((c = posix_memalign (&ptr, _align, size)) != 0) { ptr = NULL; printf (" c = %d, EINVAL = %d, ENOMEM = %d, align = %ld, size = %ld\n", c, EINVAL, ENOMEM, align, size); } if ((init != NULL) && (ptr != NULL)) { unsigned char * c; size_t i; for (i = 0, c = ptr; i < size; i++) c[i] = init[i%sizeof_init]; } if (count >= 0) __sync_fetch_and_add (&count, 1); return ptr; } void __attribute__((constructor)) memory_hook_init_ () { const char * MEMORY_HOOK_ALIGN = getenv ("MEMORY_HOOK_ALIGN"); const char * MEMORY_HOOK_INIT = getenv ("MEMORY_HOOK_INIT"); const char * MEMORY_HOOK_COUNT = getenv ("MEMORY_HOOK_COUNT"); if (MEMORY_HOOK_INIT) { if (strcasecmp (MEMORY_HOOK_INIT, "NAN") == 0) { init = &snan8[0]; sizeof_init = sizeof (snan8); } else if (strcasecmp (MEMORY_HOOK_INIT, "ZERO") == 0) { init = &zero0[0]; sizeof_init = sizeof (zero0); } else if (strncasecmp (MEMORY_HOOK_INIT, "0X", 2) == 0) { long long unsigned int x = 0; const char * c; for (c = MEMORY_HOOK_INIT+2; *c; c++) if (('0' <= *c) && (*c <= '9')) x = 16 * x + (*c - '0'); else if (('a' <= *c) && (*c <= 'f')) x = 16 * x + (*c - 'a' + 10); else if (('A' <= *c) && (*c <= 'F')) x = 16 * x + (*c - 'A' + 10); else break; init = &cinit[0]; memcpy (cinit, &x, sizeof (x)); sizeof_init = sizeof (cinit); } printf (" MEMORY_HOOK_INIT = %s\n", MEMORY_HOOK_INIT); } if (MEMORY_HOOK_ALIGN) align = atoi (MEMORY_HOOK_ALIGN); if (MEMORY_HOOK_COUNT) count = 0; } void __attribute__((destructor)) memory_hook_exit_ () { if (count > 0) printf ("MEMORY_HOOK_COUNT = %d\n", count); } #endif #endif fiat-ecmwf-2.0.0/src/fiat/system/internal/malloc_extension_c.h0000664000175000017500000001054315157200431024610 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* Copyright (c) 2008, Google Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following disclaimer * in the documentation and/or other materials provided with the * distribution. * * Neither the name of Google Inc. nor the names of its * contributors may be used to endorse or promote products derived from * this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * -- * Author: Craig Silverstein * * C shims for the C++ malloc_extension.h. See malloc_extension.h for * details. Note these C shims always work on * MallocExtension::instance(); it is not possible to have more than * one MallocExtension object in C applications. */ #ifndef _MALLOC_EXTENSION_C_H_ #define _MALLOC_EXTENSION_C_H_ #include #include /* Annoying stuff for windows -- makes sure clients can import these fns */ #ifndef PERFTOOLS_DLL_DECL # ifdef _WIN32 # define PERFTOOLS_DLL_DECL __declspec(dllimport) # else # define PERFTOOLS_DLL_DECL # endif #endif #ifdef __cplusplus extern "C" { #endif #define kMallocExtensionHistogramSize 64 PERFTOOLS_DLL_DECL int MallocExtension_VerifyAllMemory(void); PERFTOOLS_DLL_DECL int MallocExtension_VerifyNewMemory(const void* p); PERFTOOLS_DLL_DECL int MallocExtension_VerifyArrayNewMemory(const void* p); PERFTOOLS_DLL_DECL int MallocExtension_VerifyMallocMemory(const void* p); PERFTOOLS_DLL_DECL int MallocExtension_MallocMemoryStats(int* blocks, size_t* total, int histogram[kMallocExtensionHistogramSize]); PERFTOOLS_DLL_DECL void MallocExtension_GetStats(char* buffer, int buffer_length); /* TODO(csilvers): write a C version of these routines, that perhaps * takes a function ptr and a void *. */ /* void MallocExtension_GetHeapSample(string* result); */ /* void MallocExtension_GetHeapGrowthStacks(string* result); */ PERFTOOLS_DLL_DECL int MallocExtension_GetNumericProperty(const char* property, size_t* value); PERFTOOLS_DLL_DECL int MallocExtension_SetNumericProperty(const char* property, size_t value); PERFTOOLS_DLL_DECL void MallocExtension_MarkThreadIdle(void); PERFTOOLS_DLL_DECL void MallocExtension_MarkThreadBusy(void); PERFTOOLS_DLL_DECL void MallocExtension_ReleaseToSystem(size_t num_bytes); PERFTOOLS_DLL_DECL void MallocExtension_ReleaseFreeMemory(void); PERFTOOLS_DLL_DECL size_t MallocExtension_GetEstimatedAllocatedSize(size_t size); PERFTOOLS_DLL_DECL size_t MallocExtension_GetAllocatedSize(const void* p); /* * NOTE: These enum values MUST be kept in sync with the version in * malloc_extension.h */ typedef enum { MallocExtension_kUnknownOwnership = 0, MallocExtension_kOwned, MallocExtension_kNotOwned } MallocExtension_Ownership; PERFTOOLS_DLL_DECL MallocExtension_Ownership MallocExtension_GetOwnership(const void* p); #ifdef __cplusplus } // extern "C" #endif #endif /* _MALLOC_EXTENSION_C_H_ */ fiat-ecmwf-2.0.0/src/fiat/system/internal/linux_bind.c0000664000175000017500000001103315157200431023064 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2005- Meteo France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #if defined(LINUX) && !defined(_CRAYC) #define _GNU_SOURCE #include #include #include #include #include #include #include "oml.h" static char * getcpumask (char *buffer, size_t size) { cpu_set_t mask; unsigned int ncpu; unsigned int icpu; ncpu = sysconf (_SC_NPROCESSORS_CONF); sched_getaffinity (0, sizeof (mask), &mask); for (icpu = 0; icpu < ncpu; icpu++) buffer[icpu] = CPU_ISSET (icpu, &mask) ? '1' : '0'; buffer[ncpu] = '\0'; return buffer; } static void function_linux_bind_dump_parallel( void* args ) { // This function must be called within an OMP PARALLEL region // Unpack args FILE* fp = (FILE*)args; char buffer[1048576]; /* 1 megabyte */ int nomp = oml_get_max_threads(); int iomp = oml_get_thread_num(); for (int i = 0; i < nomp; i++) { if (i == iomp) { // OMP CRITICAL REGION implemented with locks oml_set_lock(); fprintf (fp, "\n mask = %s iomp = %2d", getcpumask (buffer, sizeof (buffer)), iomp); oml_unset_lock(); } oml_barrier(); } oml_barrier(); } void linux_bind_dump_ (int * prank, int * psize) { const int rank = *prank; const int size = *psize; FILE* fp = NULL; char f[256]; char host[255]; char buffer[1024]; const int nomp = oml_get_max_threads(); const unsigned int ncpu = sysconf (_SC_NPROCESSORS_CONF); sprintf (f, "linux_bind.%6.6d.txt", rank); fp = fopen (f, "w"); if (gethostname (host, 255) != 0) { strcpy (host, "unknown"); } fprintf (fp, " rank = %6d", rank); fprintf (fp, " host = %9s", host); fprintf (fp, " ncpu = %2d", ncpu); fprintf (fp, " nomp = %2d", nomp); fprintf (fp, " mask = %s", getcpumask (buffer, sizeof (buffer))); oml_init_lock(); oml_run_parallel (function_linux_bind_dump_parallel, fp); oml_destroy_lock(); fprintf (fp, "\n"); fclose (fp); } #define LINUX_BIND_TXT "linux_bind.txt" typedef struct { const char* linux_bind_txt; const char* buf; const int rank; } function_linux_bind_parallel_args_t; static void function_linux_bind_parallel(void* args) { // This function must be called within an OMP PARALLEL region // Unpack args function_linux_bind_parallel_args_t* function_args = (function_linux_bind_parallel_args_t*)args; const char* linux_bind_txt = function_args->linux_bind_txt; const char* buf = function_args->buf; const int rank = function_args->rank; const int iomp = oml_get_thread_num(); const char* c = buf; // Move c to position for this omp thread for (int jomp = 0; jomp < iomp; jomp++) { while (*c && isdigit (*c)) { c++; } while (*c && (! isdigit (*c))) { c++; } if (*c == '\0') { fprintf (stderr, "Unexpected end of line while reading '%s' on rank %d, thread %d (linux_bind.c:%d)\n", linux_bind_txt, rank, iomp, __LINE__); return; } } cpu_set_t mask; CPU_ZERO (&mask); for (int icpu = 0; isdigit (*c); icpu++, c++) { if (*c != '0') { CPU_SET (icpu, &mask); } } sched_setaffinity (0, sizeof (mask), &mask); } void linux_bind_ (int * prank, int * psize) { const int rank = *prank; const int size = *psize; const char* linux_bind_txt = getenv ("EC_LINUX_BIND"); if (linux_bind_txt == NULL) { linux_bind_txt = LINUX_BIND_TXT; } FILE* fp = fopen (linux_bind_txt, "r"); if (fp == NULL) { // Willem Deconinck: Commented out as this pollutes logs // fprintf (stderr, "`%s' was not found\n", EC_LINUX_BIND); return; } size_t len = 1024; char* buf = (char*) malloc( len ); for (int i = 0; i < rank+1; i++) { if (getline (&buf, &len, fp) == -1) { fprintf (stderr, "Unexpected end of file while reading '%s' on rank %d (linux_bind.c:%d)\n", linux_bind_txt, rank, __LINE__); fclose (fp); free (buf); return; } } function_linux_bind_parallel_args_t args = {.linux_bind_txt=linux_bind_txt, .buf=buf, .rank=rank}; oml_run_parallel (function_linux_bind_parallel, &args); fclose (fp); free (buf); } #else void linux_bind_ () { } void linux_bind_dump_ () { } #endif fiat-ecmwf-2.0.0/src/fiat/system/internal/wrap_ftn.c0000664000175000017500000000317015157200431022554 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* * Fortran wrappers for opfla_perfmon */ #ifdef PAPI #include #define BIND_FTN(upper, lower, su, du, f, sign, params) \ void upper sign { f params; } \ void lower sign { f params; } \ void su sign { f params; } \ void du sign { f params; } typedef int ftn_int; static void mpi_init_f(int *ierr) { int argc = 0; char **argv = NULL; *ierr = __wrap_MPI_Init(&argc, &argv); } static void mpi_init_thread_f(int *ierr) { int argc = 0; char **argv = NULL; int required = 0; int provided = 0; *ierr = __wrap_MPI_Init_thread(&argc, &argv, required, &provided); } static void mpi_finalize_f(int *ierr) { *ierr = __wrap_MPI_Finalize(); } BIND_FTN(__wrap_MPI_INIT, __wrap_mpi_init, __wrap_mpi_init_, __wrap_mpi_init__, mpi_init_f, (ftn_int *ierr), (ierr)) BIND_FTN(__wrap_MPI_INIT_THREAD, __wrap_mpi_init_thread, __wrap_mpi_init_thread_, __wrap_mpi_init_thread__, mpi_init_thread_f, (ftn_int *ierr), (ierr)) BIND_FTN(__wrap_MPI_FINALIZE, __wrap_mpi_finalize, __wrap_mpi_finalize_, __wrap_mpi_finalize__, mpi_finalize_f, (ftn_int *ierr), (ierr)) #else void dummy_Wrap_FTN() { } #endif fiat-ecmwf-2.0.0/src/fiat/system/internal/pthread_attr_init.c0000664000175000017500000001216115157200431024440 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #if defined(__GNUC__) || defined(__PGI) /* pthread_attr_init() interception to reset guard region size between thread stacks, by S.Saarinen, 30-Sep-2016 */ /* See : man pthread_attr_init A custom pthread_attr_init() mainly to control the memory "gap" or protected "guard size" between slave threads Slave threads allocate memory from the heap -- only master thread allocates from (genuine) stack Guard region is usually very small and it is possible that a slave thread may (accidentally) overwrite to the adjacent slave threads memory arena. By setting the guard size big enough, usually a few MiB suffice, then an overwrite could hit this protected memory area easier triggering usually a SIGSEGV. The traceback that follows usually shows the code location and allows to fix the issue for good. To set the guard size use : export EC_THREAD_GUARDSIZE=[G|M|K] Caveat: Some MPI drivers may not like this -- check especially the Mellanox HPC-X/OpenMPI */ #include #include #include #include #include #include #include #include #include #include #include #include #include #undef RNDUP_DIV #define RNDUP_DIV(i,n) (( (i) + (n) - 1 ) / (n)) #undef RNDUP #define RNDUP(i,n) ( RNDUP_DIV(i,n) * (n)) #if defined(RTLD_NEXT) #define PTR_LIBC RTLD_NEXT #else #define PTR_LIBC ((void*) -1L) #endif static int (*ptr_pthread_attr_init)(pthread_attr_t *attr) = NULL; int pthread_attr_init(pthread_attr_t *attr) { int rc; static int done = 0; FILE *fp = NULL; extern int ec_mpirank(), ec_gettid(); // ec_env.c int me = ec_mpirank(); // Could be called before the MPI_Init*() or w/o presence of MPI (i.e. rank 0) pid_t pid = getpid(); pid_t tid = ec_gettid(); int master = (pid == tid) ? 1 : 0; if (!ptr_pthread_attr_init) { ptr_pthread_attr_init = (int (*)(pthread_attr_t *a))dlsym(PTR_LIBC, "pthread_attr_init"); if (!ptr_pthread_attr_init) { fprintf(stderr,"***Error: Dynamic linking to pthread_attr_init() failed : errno = %d\n",errno); abort(); } /* We intend to output only from MPI-task 0, master thread */ if (!done && me == 0 && master) fp = stderr; done = 1; } rc = ptr_pthread_attr_init(attr); { char *env_gs = getenv("EC_THREAD_GUARDSIZE"); if (!env_gs) env_gs = getenv("THREAD_GUARDSIZE"); // Compatibility if (env_gs) { size_t pgsize = getpagesize(); size_t guardsize = atoll(env_gs); if (strchr(env_gs,'G')) guardsize *= 1073741824; /* hence, in GiB */ else if (strchr(env_gs,'M')) guardsize *= 1048576; /* hence, in MiB */ else if (strchr(env_gs,'K')) guardsize *= 1024; /* hence, in KiB */ guardsize = RNDUP(guardsize,pgsize); if (guardsize > pgsize) { /* Now we *DO* bother */ char *env_omp = getenv("OMP_STACKSIZE"); size_t omp_stacksize = env_omp ? atoll(env_omp) : 0; size_t stacksize = 0; int iret = pthread_attr_getstacksize(attr,&stacksize); #if 1 if (fp) fprintf(fp, "[%s@%s:%d] [pid=%ld:tid=%ld]: Requesting guard region size " "between thread stacks : %lld bytes (%s PAGESIZE = %ld)\n", __FUNCTION__,__FILE__,__LINE__, (long int)pid,(long int)tid, (long long int)guardsize, (guardsize > pgsize) ? ">" : "<=", (long)pgsize); #endif if (env_omp) { if (strchr(env_omp,'G')) omp_stacksize *= 1073741824; /* hence, in GiB */ else if (strchr(env_omp,'M')) omp_stacksize *= 1048576; /* hence, in MiB */ else if (strchr(env_omp,'K')) omp_stacksize *= 1024; /* hence, in KiB */ } if (fp) fprintf(fp, "[%s@%s:%d] [pid=%ld:tid=%ld]: Stack size(s) : %lld bytes (def), %lld bytes (OMP) : [iret=%d]\n", __FUNCTION__,__FILE__,__LINE__, (long int)pid,(long int)tid, (long long int)stacksize, (long long int)omp_stacksize, iret); if (iret == 0 && omp_stacksize > guardsize) { iret = pthread_attr_setguardsize(attr,guardsize); (void) pthread_attr_getguardsize(attr,&guardsize); if (fp) fprintf(fp, "[%s@%s:%d] [pid=%ld:tid=%ld]: Guard region size now : %lld bytes : [iret=%d]\n", __FUNCTION__,__FILE__,__LINE__, (long int)pid,(long int)tid, (long long int)guardsize,iret); } } } } if (fp) fflush(fp); return rc; } #endif /* defined(__GNUC__) || defined(__PGI) */ fiat-ecmwf-2.0.0/src/fiat/system/internal/get_tcmalloc_info.c0000664000175000017500000000277215157200431024413 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* Wrappers to obtain information from tcmalloc Peter Towers - June 2014 Made it working with any compiler providing libtcmalloc_minimal.so was linked in Sami Saarinen - November 2017 */ #include "malloc_extension_c.h" #include #pragma weak MallocExtension_GetNumericProperty size_t get_tcmalloc_heap_size_() { size_t value=0; if (MallocExtension_GetNumericProperty) { MallocExtension_GetNumericProperty("generic.heap_size", &value); } return value; } size_t get_tcmalloc_current_allocated_bytes_() { size_t value=0; if (MallocExtension_GetNumericProperty) { MallocExtension_GetNumericProperty("generic.current_allocated_bytes", &value); } return value; } size_t get_tcmalloc_pageheap_free_bytes_() { size_t value=0; if (MallocExtension_GetNumericProperty) { MallocExtension_GetNumericProperty("tcmalloc.pageheap_free_bytes", &value); } return value; } size_t get_tcmalloc_pageheap_unmapped_bytes_() { size_t value=0; if (MallocExtension_GetNumericProperty) { MallocExtension_GetNumericProperty("tcmalloc.pageheap_unmapped_bytes", &value); } return value; } fiat-ecmwf-2.0.0/src/fiat/system/internal/tabort.c0000664000175000017500000000444515157200431022235 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include #include #include #include #include "drhook.h" #include "mpl.h" extern void abor1_(const char msg[], int msglen); extern int ec_sleep(const int nsec); #pragma weak abor1_ // Forward declarations extern void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr); extern void ec_microsleep(int usecs); // from ec_env.c extern void fortran_mpi_abort(int rc); extern int fortran_mpi_initialized(); static const char tabort_lockfile[] = "tabort_lock"; void tabort_delete_lockfile() { if (access(tabort_lockfile, F_OK) != -1) { // File is found remove(tabort_lockfile); } } void tabort_delete_lockfile_() { tabort_delete_lockfile(); } void tabort_() { const int sig = SIGABRT; int rc = 128 + sig; static volatile sig_atomic_t irecur = 0; if (++irecur == 1) { // only one thread per task ever gets here // Only the fastest MPI task calls LinuxTraceBack -- avoids messy outputs int mpi_init = fortran_mpi_initialized(); int nfirst = (mpi_init ? 0 : 1); if( nfirst == 0 ) { int fd = open(tabort_lockfile,O_CREAT|O_TRUNC|O_EXCL,S_IRUSR|S_IWUSR); if (fd >= 0) { close(fd); nfirst = 1; } } if (nfirst) { drhook_calltree(); LinuxTraceBack(NULL,NULL,NULL); } else { const int nsecs = 100; ec_sleep(nsecs); } if (mpi_init) { fortran_mpi_abort(rc); // calls MPI_ABORT with MPI_COMM_WORLD } else { abort(); } } // Still here ?? get the hell out of here ... now !! _exit(rc); } void abort_() { if (abor1_) { // Call only if available static volatile sig_atomic_t irecur = 0; if (++irecur == 1) { const char msg[] = "Fortran ABORT()"; abor1_(msg,strlen(msg)); } } tabort_(); } void _gfortran_abort() { abort_(); } fiat-ecmwf-2.0.0/src/fiat/system/internal/opfla_perfmon.c0000664000175000017500000002516115157200431023567 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifdef PAPI #define _GNU_SOURCE #include #include #include #include /* sleep(1) */ #include #include #include #include #include struct eval { double val; int rank; }; int rank; //rank int numranks; //total number of ranks char affinity[128];//core affinity pid_t pid; //pid of process char nodename[128]; //nodename FILE *fp; //outputfil #define NUM_EV 4 long_long papi_values[NUM_EV]; long_long start_usec_p; long_long start_usec_r; int init_error; struct thread_data{ pthread_t parent_thread; float report_interval; }; //global as it needs to live on also if master thread leaves MPI_Init... struct thread_data td; /* Borrowed from util-linux-2.13-pre7/schedutils/taskset.c */ static char *cpuset_to_cstr(cpu_set_t *mask, char *str) { char *ptr = str; int i, j, entry_made = 0; for (i = 0; i < CPU_SETSIZE; i++) { if (CPU_ISSET(i, mask)) { int run = 0; entry_made = 1; for (j = i + 1; j < CPU_SETSIZE; j++) { if (CPU_ISSET(j, mask)) run++; else break; } if (!run) sprintf(ptr, "%d,", i); else if (run == 1) { sprintf(ptr, "%d,%d,", i, i + 1); i++; } else { sprintf(ptr, "%d-%d,", i, i + run); i += run; } while (*ptr != 0) ptr++; } } ptr -= entry_made; *ptr = 0; return(str); } static void getProcessIdentity(char *hostname,int hostnamesize,char *affinity,int affinitysize,int *rank,int *numranks,pid_t *pid){ cpu_set_t coremask; (void)gethostname(hostname,hostnamesize); (void)sched_getaffinity(0, sizeof(coremask), &coremask); cpuset_to_cstr(&coremask, affinity); MPI_Comm_rank(MPI_COMM_WORLD,rank); MPI_Comm_size(MPI_COMM_WORLD,numranks); //pid *pid=getpid(); } static int parseMeminfo(const char *label){ int i; int done=0; FILE *fp=fopen("/proc/meminfo","r"); char line[120]; char *subline; int val=-1; int label_length=strlen(label); while(!done && fp!=NULL){ if (fgets(line,sizeof(line),fp)) { subline=strstr(line,label); if(subline!=NULL){ val=atoi(subline+label_length); fclose(fp); return val; } } } fclose(fp); return val; } static int report_init(int periodicreport){ double rtime,ptime; int events[NUM_EV]; int rc, num; static int first_time = 1; /* open file if we use files and write headers*/ if(periodicreport){ char fname[40]; sprintf(fname,"perfmon_report_%d.dat",rank); fp=fopen(fname,"w"); if(fp==NULL){ return 2; } //header fprintf(fp,"# rank: %d nodename: %s core-affinity: %s \n",rank,nodename,affinity); fprintf(fp,"#rtime ptime gflops l1-hit memusage(MB) freeMem(MB)\n"); } if (!first_time) return 0; first_time = 0; //get papi info, first time it intializes PAPI counters/library events[0]=PAPI_L1_DCM; events[1]=PAPI_L1_DCH; events[2]=PAPI_FP_OPS; events[3]=PAPI_TOT_INS; rc = (num = PAPI_num_counters()); if (rc != PAPI_OK) { PAPI_perror("PAPI_num_counters"); } //fprintf(stderr,"PAPI_num_counters = %d\n",num); rc = PAPI_start_counters(events, NUM_EV); if (rc != PAPI_OK) { return rc; } start_usec_r=PAPI_get_real_usec(); start_usec_p=PAPI_get_virt_usec(); return 0; } static void report_periodic(){ double rtime,ptime; static double prevrtime=0.0; double freemem; double memuse; double gflops,l1hitratio; PAPI_dmem_info_t dmem; int i; //get papi info, long_long end_usec_r,end_usec_p; long_long prev_values[NUM_EV]; end_usec_r = PAPI_get_real_usec(); end_usec_p = PAPI_get_virt_usec(); rtime=(double)(end_usec_r-start_usec_r)/1e6; ptime=(double)(end_usec_p-start_usec_p)/1e6; //get memdata PAPI_get_dmem_info(&dmem); for(i=0;ireport_interval>0){ //find out how many total seconds and mikroseconds to sleep int sec=(int)tdloc->report_interval; int usec=(int)((tdloc->report_interval-sec)*1.0e6); //do not allow busy loop when interval less than usec while(sec+usec>0){ if(sec>0) sleep(sec); if(usec>0) usleep(usec); //send signal to parent thread that it should report flops etc. pthread_kill(tdloc->parent_thread,SIGUSR1); } } return NULL; } static void common_inits() { pthread_t t; pthread_attr_t thread_attr; int thread_id,thread_create_return; int temp; char *envvar; //initialize global values for process identity getProcessIdentity(nodename,sizeof(nodename),affinity,sizeof(affinity),&rank,&numranks,&pid); //init parameters envvar=getenv("PERFMON_INTERVAL"); if(envvar==NULL){ td.report_interval=-1; //default never } else { td.report_interval=atof(envvar); } /* if report interval is larger or equal to 10ms then do "unsafe" periodic reporting stuff; start up signal handling and launch thread */ if(td.report_interval>=0.009999) { //initialize PAPI counters with periodic reporting init_error=report_init(1); if(!init_error){ //print PAPI counters when receiving signal USR1 signal(SIGUSR1,report_periodic); //launch sampling thread td.parent_thread=pthread_self(); temp=pthread_create(&t,NULL,thread_worker,(void *)&td); } } else { //initialize PAPI counters without periodic reporting fprintf(stderr,"Calling report_init(0)\n"); init_error=report_init(0); if (init_error) fprintf(stderr, "Unable to init PAPI counters (init_error=%d) : %s\n", init_error, PAPI_strerror(init_error) ); } } int __wrap_MPI_Init(int *argc, char ***argv) { //call true MPI_Init int ret= __real_MPI_Init(argc, argv); common_inits(); return ret; } int __wrap_MPI_Init_thread(int *argc, char ***argv, int required, int *provided) { //call true MPI_Init_thread int ret= __real_MPI_Init(argc, argv, required, provided); common_inits(); return ret; } int __wrap_MPI_Finalize() { //only print if startup was without errors if(!init_error) report_final(stdout,NULL); return __real_MPI_Finalize(); } void csc_perfmon_begin_ () { common_inits(); } void csc_perfmon_begin__ () { csc_perfmon_begin_(); } void csc_perfmon_begin () { csc_perfmon_begin_(); } void CSC_PERFMON_BEGIN () { csc_perfmon_begin_(); } void csc_perfmon_end_ () { if(!init_error) report_final(stdout,NULL); } void csc_perfmon_end__ () { csc_perfmon_end_(); } void csc_perfmon_end () { csc_perfmon_end_(); } void CSC_PERFMON_END () { csc_perfmon_end_(); } #else void dummy_Opfla_PERFMOM() { } #endif fiat-ecmwf-2.0.0/src/fiat/system/internal/linuxtrbk.c0000664000175000017500000003515315157200431022764 0ustar alastairalastair/* * (C) Copyright 2006- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* linuxtrbk.c : Print traceback on linux */ /* Author: Sami Saarinen, ECMWF, 28-Apr-2006 The code "nicked" from ifsaux/support/drhook.c */ //#if (defined(__GNUC__) || defined(__PGI)) #define _GNU_SOURCE //#endif #include #include #include #include #include #include #include #include #include "ec_args.h" #include "drhook.h" #define PRETOSTR(x) #x #define TOSTR(x) PRETOSTR(x) #define strequ(s1,s2) ((void *)s1 && (void *)s2 && strcmp(s1,s2) == 0) #define strnequ(s1,s2,n) ((void *)s1 && (void *)s2 && memcmp(s1,s2,n) == 0) #ifdef WITHOUT_CXXDEMANGLE static char *cxxdemangle(const char *mangled_name, int *status) { if( status ) *status = 1; return NULL; } #endif typedef struct { const char *func; const char *file; unsigned int lineno; } BFD_t; static int ResolveViaBFD(void *address, BFD_t *b, const char *str); static void InitBFD(); #ifndef LINELEN #define LINELEN 1024 #define FFL __FUNCTION__,__FILE__,__LINE__ #if (defined(__GNUC__) || defined(__PGI)) #include #include #include #if defined(__APPLE__) // define _XOPEN_SOURCE to enable deprecated use of ucontext.h #define _XOPEN_SOURCE #endif #if !defined(CYGWIN) && !defined(__NEC__) #include #include #endif #endif /* defined(__GNUC__) */ #if !defined(ADDR2LINE) #define ADDR2LINE /usr/bin/addr2line #endif #define len_addr2linecmd (sizeof(TOSTR(ADDR2LINE)) + 80 + 4096 + GNUC_BTRACE * 30) static char prealloc_addr2linecmd[len_addr2linecmd] = ""; #ifdef BFDLIB #include static const int has_bfd = 1; #else static const int has_bfd = 0; #endif void gdb_trbk(); // defined below void dbx_trbk(); // defined below void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr); // defined below #ifdef __NEC__ void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr) { #if 1 // When VE_TRACEBACK=ALL the following should have the same impact as with implicit traceback (when compiled & linked with -traceback) // NB: No control on output channel if (!sigcontextptr) sigcontextptr = __builtin_frame_address(0); __builtin_traceback(sigcontextptr); #else gdb_trbk(); #endif } #elif defined(CYGWIN) void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr) { const char *pfx = prefix ? prefix : drhook_PREFIX(0); const char *ts = timestr ? timestr : drhook_TIMESTR(0); int sigcontextptr_given = sigcontextptr ? 1 : 0; static int recur = 0; const char *a_out = ec_argv()[0]; fprintf(stderr,"%s %s [LinuxTraceBack] Backtrace(s) for program '%s' : sigcontextptr=%p\n", pfx,ts,a_out ? a_out : "/dev/null", sigcontextptr); if (++recur > 1) { fprintf(stderr, "%s %s [LinuxTraceBack] I don't handle recursive calls very well (recursion level = %d)\n", pfx,ts,recur); if (recur > 10) { fprintf(stderr,"%s %s [LinuxTraceBack] Recursion too deep. Exiting immediately with _exit(%d)\n", pfx,ts,recur); fflush(NULL); _exit(recur); /* Exit immediately */ } } if (!sigcontextptr_given) goto finish; gdb_trbk(); dbx_trbk(); finish: fprintf(stderr,"%s %s [%s@%s:%d] End of backtrace(s)\n",pfx,ts,FFL); recur--; } #else void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr) { int sigcontextptr_given = sigcontextptr ? 1 : 0; static int recur = 0; #if (defined(__GNUC__) || defined(__PGI)) ucontext_t ctx; if (!sigcontextptr) { sigcontextptr = (getcontext(&ctx) == 0) ? &ctx : NULL; } #endif const char *pfx = prefix ? prefix : drhook_PREFIX(0); const char *ts = timestr ? timestr : drhook_TIMESTR(0); const char *a_out = ec_argv()[0]; const char *s1 = strlen(pfx) ? " " : ""; const char *s2 = strlen(ts) ? " " : ""; fprintf(stderr,"%s%s%s%s[LinuxTraceBack] Backtrace(s) for program '%s' : sigcontextptr=%p\n", pfx,s1,ts,s2,a_out ? a_out : "/dev/null", sigcontextptr); if (++recur > 1) { fprintf(stderr, "%s%s%s%s[LinuxTraceBack] I don't handle recursive calls very well (recursion level = %d)\n", pfx,s1,ts,s2,recur); if (recur > 10) { fprintf(stderr,"%s%s%s%s[LinuxTraceBack] Recursion too deep. Exiting immediately with _exit(%d)\n", pfx,s1,ts,s2,recur); _exit(recur); /* Exit immediately */ } } #if (defined(__GNUC__) || defined(__PGI)) if (sigcontextptr) { /* To have a desired effect, compile with -g (and maybe -O1 or greater to get some optimization) and link with -g -Wl,-export-dynamic */ char *linuxtrbk_fullpath = getenv("LINUXTRBK_FULLPATH"); int linuxtrbk_fullpath_on = (linuxtrbk_fullpath && *linuxtrbk_fullpath == '1') ? 1 : 0; void *trace[GNUC_BTRACE]; ucontext_t *uc = (ucontext_t *)sigcontextptr; int fd = fileno(stderr); int trace_size = backtrace(trace, GNUC_BTRACE); char *addr2linecmd = (has_bfd || (access(TOSTR(ADDR2LINE),X_OK) != 0)) ? NULL : prealloc_addr2linecmd; char **strings = NULL; if (trace_size > 1) { /* overwrite sigaction with caller's address */ #ifdef __powerpc64__ trace[1] = uc ? (void *) uc->uc_mcontext.regs->nip : NULL; // Trick from PAPI_overflow() #elif defined(__x86_64__) && defined(REG_RIP) // gcc specific trace[1] = uc ? (void *) uc->uc_mcontext.gregs[REG_RIP] : NULL; // RIP: x86_64 specific ; only available in 64-bit mode */ #elif defined(__i386__) && defined(REG_EIP) // gcc specific trace[1] = uc ? (void *) uc->uc_mcontext.gregs[REG_EIP] : NULL; // EIP: x86 specific ; only available in 32-bit mode */ #endif } strings = backtrace_symbols(trace, trace_size); fprintf(stderr,"%s%s%s%s[LinuxTraceBack] Backtrace (size = %d) with %s\n", pfx,s1,ts,s2,trace_size, addr2linecmd ? "addr2line-cmd" : has_bfd ? "BFD-method" : "plain hex-dump"); if (strings && trace_size > 0) { int i; FILE *fp = NULL; if (addr2linecmd) { /* Use ADDR2LINE to obtain source file & line numbers for each trace-address */ //snprintf(addr2linecmd, len_addr2linecmd, "%s -fs -e '%s'", TOSTR(ADDR2LINE), a_out); strcpy(addr2linecmd,TOSTR(ADDR2LINE)); strcat(addr2linecmd," -fs -e '"); strcat(addr2linecmd,a_out); strcat(addr2linecmd,"'"); for (i = 0; i < trace_size; i++) { char s[30]; if (trace[i]) snprintf(s,sizeof(s)," %p",trace[i]); else snprintf(s,sizeof(s)," 0x0"); strcat(addr2linecmd,s); } if (getenv("LD_PRELOAD")) { static char ld_preload[] = "LD_PRELOAD="; putenv(ld_preload); } fprintf(stderr,"%s%s%s%s[LinuxTraceBack] %s\n", pfx,s1,ts,s2,addr2linecmd); fp = popen(addr2linecmd,"r"); /* free(addr2linecmd); */ } if (fp) { int ndigits = (trace_size > 0) ? 1 + (int)log10(trace_size) : 0; extern char *cxxdemangle(const char *mangled_name, int *status); // cxxdemangle.cc (C++ code) : returned string must be free'd for (i = 0; i < trace_size; i++) { int ok = 0; char func[LINELEN]; if (!feof(fp) && fgets(func, LINELEN, fp)) { char line[LINELEN]; if (!feof(fp) && fgets(line, LINELEN, fp)) { char *cxxfunc = NULL; char *nl = strchr(func,'\n'); char *leftB, *plus; const char *last_slash = linuxtrbk_fullpath_on ? NULL : strrchr(strings[i],'/'); if (last_slash) last_slash++; else last_slash = strings[i]; if (nl) *nl = '\0'; cxxfunc = cxxdemangle(func,NULL); nl = strchr(line,'\n'); if (nl) *nl = '\0'; leftB = strchr(last_slash,'('); plus = strrchr(last_slash,'+'); if (leftB && plus && (int)(plus-leftB) > 1) { int istat = 0; char *cxx = NULL; char *therest = plus + 1; *plus = '\0'; cxx = cxxdemangle(leftB + 1,&istat); if (cxx) *leftB = '\0'; fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s%s%s+%s : %s%s at %s\n", pfx,s1,ts,s2, ndigits, ndigits, i, last_slash, cxx ? "(" : "", cxx ? cxx : "", therest, cxxfunc ? cxxfunc : func, cxxfunc ? "" : "()", line); if (cxx) free(cxx); } else { fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s : %s%s at %s\n", pfx,s1,ts,s2, ndigits, ndigits, i, last_slash, cxxfunc ? cxxfunc : func, cxxfunc ? "" : "()", line); } if (cxxfunc) free(cxxfunc); ok = 1; } } if (!ok) { char *cxx = cxxdemangle(strings[i],NULL); fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s\n", pfx,s1,ts,s2, ndigits, ndigits, i, cxx ? cxx : strings[i]); if (cxx) free(cxx); } } /* for (i = 0; i < trace_size; i++) */ fflush(stderr); pclose(fp); } /* if (fp) */ else { int ndigits = (trace_size > 0) ? 1 + (int)log10(trace_size) : 0; InitBFD(); for (i = 0 ; i < trace_size; ++i) { BFD_t b; const char *last_slash = linuxtrbk_fullpath_on ? NULL : strrchr(strings[i],'/'); if (last_slash) last_slash++; else last_slash = strings[i]; if (ResolveViaBFD(trace[i], &b, last_slash) == 0 /*success*/) { fprintf(stderr,"%s%s%s%s[LinuxTraceBack] [%*.*d]: %s : %s() at %s:%u\n", pfx,s1,ts,s2,ndigits,ndigits,i, last_slash,b.func,b.file,b.lineno); } else { fprintf(stderr,"%s%s%s%s[LinuxTraceBack] [%*.*d]: %s : %p\n", pfx,s1,ts,s2,ndigits,ndigits,i, last_slash,trace[i]); } } } } else { /* Print traceback directly to fd=2 (stderr) */ backtrace_symbols_fd(trace, trace_size, fd); } /* if (addr2linecmd) else ... */ if (strings) free(strings); /* Could we live without this free() ? */ } #endif /* __GNUC__ */ if (!sigcontextptr_given) goto finish; gdb_trbk(); dbx_trbk(); finish: fprintf(stderr,"%s%s%s%s[LinuxTraceBack] End of backtrace(s)\n",pfx,s1,ts,s2); recur--; } #endif void linux_trbk_(void) { LinuxTraceBack(NULL,NULL,NULL); } #else /* Non-Linux: A dummy call which does nothing */ void LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr) { } void linux_trbk_(void) { } #endif void linux_trbk(void) { linux_trbk_(); } /* GNU-debugger traceback */ #if !defined(GNUDEBUGGER) #define GNUDEBUGGER /usr/bin/gdb #endif void gdb_trbk_() { char *gdb = getenv("GNUDEBUGGER"); if (gdb && (access(TOSTR(GNUDEBUGGER),X_OK) == 0) && /* GNUDEBUGGER was set */ (strequ(gdb,"1") || strequ(gdb,"true") || strequ(gdb,"TRUE"))) { char gdbcmd[65536]; pid_t pid = getpid(); const char *a_out = ec_argv()[0]; fprintf(stderr, "[gdb_trbk] : Invoking %s ...\n", TOSTR(GNUDEBUGGER)); snprintf(gdbcmd,sizeof(gdbcmd), "set +eux; %s -batch -n -q -ex 'thread apply all bt' %s %ld < /dev/null", TOSTR(GNUDEBUGGER), a_out, (long int)pid); /* fprintf(stderr,"%s\n",gdbcmd); */ { int idummy = system(gdbcmd); } } } void gdb_trbk() { gdb_trbk_(); } /* DBX-debugger traceback */ #if !defined(DBXDEBUGGER) #define DBXDEBUGGER /usr/bin/dbx #endif void dbx_trbk_() { char *dbx = getenv("DBXDEBUGGER"); if (dbx && (access(TOSTR(DBXDEBUGGER),X_OK) == 0) && /* DBXDEBUGGER was set */ (strequ(dbx,"1") || strequ(dbx,"true") || strequ(dbx,"TRUE"))) { pid_t pid = getpid(); const char *a_out = ec_argv()[0]; char dbxcmd[65536]; const char *qopt = ""; fprintf(stderr, "[dbx_trbk] : Invoking %s ...\n", TOSTR(DBXDEBUGGER)); if (a_out && (access(a_out,X_OK|R_OK) == 0)) { snprintf(dbxcmd,sizeof(dbxcmd), "set +e; /bin/echo 'where; quit; '" " | %s%s %s %d ", TOSTR(DBXDEBUGGER), qopt, a_out, pid); } else { snprintf(dbxcmd,sizeof(dbxcmd), "set +e; /bin/echo 'where; quit; '" " | %s%s - %d ", TOSTR(DBXDEBUGGER), qopt, pid); } /* fprintf(stderr,"%s\n",dbxcmd); */ { int idummy = system(dbxcmd); } } } void dbx_trbk() { dbx_trbk_(); } #ifdef BFDLIB static bfd *abfd = 0; static asymbol **syms = 0; static asection *text = 0; #endif static void InitBFD() { #ifdef BFDLIB if (!abfd) { const char *a_out = ec_argv()[0]; bfd_init(); abfd = bfd_openr(a_out, 0); if (!abfd) { perror("bfd_openr failed: "); return; } bfd_check_format(abfd,bfd_object); unsigned int storage_needed = bfd_get_symtab_upper_bound(abfd); syms = (asymbol **) malloc(storage_needed); unsigned int cSymbols = bfd_canonicalize_symtab(abfd, syms); text = bfd_get_section_by_name(abfd, ".text"); } #endif } static int ResolveViaBFD(void *address, BFD_t *b, const char *str) { int rc = -1; #ifdef BFDLIB if (!abfd) InitBFD(); if (b) { long offset = (long)(address - text->vma); if (offset > 0) { memset(b,0x0,sizeof(*b)); if (bfd_find_nearest_line(abfd, text, syms, offset, &b->file, &b->func, &b->lineno) && b->file && b->func) { const char *last_slash = strrchr(b->file,'/'); if (last_slash) b->file = last_slash + 1; rc = 0; } else if (str) { static const char qmarks[] = "??"; if (!b->func) { static char *s = NULL; // Not thread safe char *loc_lbr; if (s) free(s); s = strdup(str); loc_lbr = strchr(s,'('); if (loc_lbr) { char *loc_add = NULL; *loc_lbr++ = 0; loc_add = strchr(loc_lbr,'+'); if (loc_add) *loc_add = 0; b->func = loc_lbr; } else { b->func = qmarks; } } if (!b->file) b->file = qmarks; rc = 0; } /* if (bfd_find_nearest_line(...)) else if (str) ... */ } } #endif return rc; } fiat-ecmwf-2.0.0/src/fiat/system/internal/cxxdemangle.cc0000664000175000017500000000146115157200431023377 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include extern "C" char *cxxdemangle(const char *mangled_name, int *status) { int istat = 0; #ifdef __NEC__ // Where is libstdc++ on NEC Aurora ?? char *demangled_name = NULL; #else char *demangled_name = abi::__cxa_demangle(mangled_name, NULL, NULL, &istat); #endif if (status) *status = istat; return demangled_name; // this must be free()'d by the user } fiat-ecmwf-2.0.0/src/fiat/system/ec_get_cycles.c0000664000175000017500000000612215157200431021710 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include "ec_get_cycles.h" #include "cas.h" // Borrowed from PAPI -- currently (27-Sep-2019/SS) just x86, Power & ARM versions // Fortran callable #if (defined(__i386__)||defined(__x86_64__)) // X86 long long int ec_get_cycles_() { long long int ret = 0; #ifdef __x86_64__ do { unsigned int a, d; asm volatile ( "rdtsc":"=a" ( a ), "=d"( d ) ); ( ret ) = ( ( long long int ) a ) | ( ( ( long long int ) d ) << 32 ); } while ( 0 ); #else __asm__ __volatile__( "rdtsc":"=A"( ret ): ); #endif return ret; } #elif defined(__powerpc__) // POWER PC #include #include #include #include #include long long int ec_get_cycles_() { uint64_t result; int64_t retval; unsigned long int dummy; static volatile uint64_t multiplier = 1; if (multiplier == 1) { // once only static volatile sig_atomic_t mylock = 0; cas_lock(&mylock); if (multiplier == 1) { FILE *fp; extern int ec_coreid(); // from ec_env.c int cpuid = ec_coreid(); const char max_freq_file_fmt[] = "/sys/devices/system/cpu/cpu%d/cpufreq/cpuinfo_max_freq"; // in kHZ char file[PATH_MAX]; snprintf(file,sizeof(file),max_freq_file_fmt,cpuid); fp = fopen(file,"r"); if (fp) { int max_khz = 0; if (fscanf(fp,"%d",&max_khz) == 1) { multiplier = ((uint64_t)max_khz * 1000000ULL) / __ppc_get_timebase_freq(); } else { multiplier = 0; // failed } fclose(fp); } else { perror(file); multiplier = 0; // failed } } cas_unlock(&mylock); } #ifdef __powerpc64__ /* This reads timebase in one 64bit go. Does *not* include a workaround for the cell (see http://ozlabs.org/pipermail/linuxppc-dev/2006-October/027052.html) */ __asm__ volatile( "mftb %0" : "=r" (result)); #else /* Read the high 32bits of the timer, then the lower, and repeat if high order has changed in the meantime. See http://ozlabs.org/pipermail/linuxppc-dev/1999-October/003889.html */ __asm__ volatile( "mfspr %1,269\n\t" /* mftbu */ "mfspr %L0,268\n\t" /* mftb */ "mfspr %0,269\n\t" /* mftbu */ "cmpw %0,%1\n\t" /* check if the high order word has chanegd */ "bne $-16" : "=r" (result), "=r" (dummy)); #endif retval = (result*multiplier)/1000ULL; return retval; } #elif defined(__aarch64__) // ARM 64 long long ec_get_cycles_() { register unsigned long ret; __asm__ __volatile__ ("isb; mrs %0, cntvct_el0" : "=r" (ret)); return ret; } #else long long int ec_get_cycles_() { return 0; } #endif long long int ec_get_cycles() { return ec_get_cycles_(); } fiat-ecmwf-2.0.0/src/fiat/system/getmemvals.F900000664000175000017500000000304215157200431021376 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GETMEMVALS(N, KEY, KVAL) USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: N, KEY(N) INTEGER(KIND=JPIB), INTENT(OUT):: KVAL(N) !--------------------------------- key ---------------------------------------------- INTEGER(KIND=JPIB), EXTERNAL :: GETHWM ! 1 High Water Mark for HEAP-alloc INTEGER(KIND=JPIB), EXTERNAL :: GETMAXRSS ! 2 Maximum resident memory so far INTEGER(KIND=JPIB), EXTERNAL :: GETCURHEAP! 3 Instantaneous allocation from ALLOCATE/malloc INTEGER(KIND=JPIB), EXTERNAL :: GETSTK ! 4 Instantaneous stack usage INTEGER(KIND=JPIB), EXTERNAL :: GETMAXSTK ! 5 Maximum stack usage so far INTEGER(KIND=JPIB), EXTERNAL :: GETPAG ! 6 I/O caused by paging ! -- add more as required (all 64-bit integers upon return, though) -- INTEGER(KIND=JPIM) J DO J=1,N IF (KEY(J) == 1) THEN KVAL(J) = GETHWM() ELSE IF (KEY(J) == 2) THEN KVAL(J) = GETMAXRSS() ELSE IF (KEY(J) == 3) THEN KVAL(J) = GETCURHEAP() ELSE IF (KEY(J) == 4) THEN KVAL(J) = GETSTK() ELSE IF (KEY(J) == 5) THEN KVAL(J) = GETMAXSTK() ELSE IF (KEY(J) == 6) THEN KVAL(J) = GETPAG() ENDIF ENDDO END SUBROUTINE GETMEMVALS fiat-ecmwf-2.0.0/src/fiat/system/getpag.c0000664000175000017500000000100715157200431020364 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #define getpag getpag_ long long int getpag() { return 0L; } fiat-ecmwf-2.0.0/src/fiat/system/getmaxrss.c0000664000175000017500000000142615157200431021137 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ typedef long long int ll_t; #include #include ll_t getmaxrss_() { #ifdef __APPLE__ const ll_t scaler = 1; /* ru_maxrss is defined in bytes */ #else const ll_t scaler = 1024; /* ru_maxrss is defened in kilobytes */ #endif ll_t rc = 0; struct rusage r; rc = getrusage(RUSAGE_SELF, &r); rc = (rc == 0) ? (ll_t) r.ru_maxrss * scaler : 0; return rc; } fiat-ecmwf-2.0.0/src/fiat/system/getcurheap.c0000664000175000017500000000422115157200431021245 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include typedef long long int ll_t; #define getcurheap getcurheap_ #define getmaxcurheap getmaxcurheap_ #define getcurheap_thread getcurheap_thread_ #define getmaxcurheap_thread getmaxcurheap_thread_ #define getmaxloc getmaxloc_ #define resetmaxloc resetmaxloc_ #define profile_heap_get profile_heap_get_ static ll_t maxloc = 0; /* For stackcheck */ static ll_t begloc = 0; /* For stackcheck */ static int heapcheck = 0; /* Fro heapcheck */ extern ll_t gethwm_(); static ll_t maxcurheap = 0; void profile_heap_get(ll_t val[], const int *Nval, const int *Icase, int *nret) /* Fortran callable */ { *nret = 0; } ll_t getcurheap() { // Cray linker: if you intend to link with -hstd_alloc and use Cray C compiler, then compile this file with -DSTD_ALLOC too #if !defined(STD_ALLOC) && (defined(_CRAYC) || defined(USE_TCMALLOC)) extern size_t get_tcmalloc_current_allocated_bytes_(); return get_tcmalloc_current_allocated_bytes_(); #else ll_t rc = gethwm_(); if (rc > maxcurheap) maxcurheap = rc; return rc; #endif } ll_t getcurheap_thread(const int *thread_id) { return getcurheap(); } /* Maximum (total) current (virtual mem) allocation encountered */ ll_t getmaxcurheap() { return 0; } /* Maximum (total) current (virtual mem) allocation encountered per thread */ ll_t getmaxcurheap_thread(const int *thread_id) /* ***Note: YOMOML thread id */ { return 0; } ll_t getmaxloc() { ll_t z=maxloc-begloc; return z; } void resetmaxloc() { maxloc=0; } void setheapcheck_() { heapcheck=1; } // Unused function, works around warning of unused heapcheck variable int getheapcheck_() { return heapcheck; } fiat-ecmwf-2.0.0/src/fiat/system/getheapstat.F900000664000175000017500000000543615157200431021554 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GETHEAPSTAT(KOUT, CDLABEL) USE EC_PARKIND ,ONLY : JPIM ,JPRD ,JPIB USE MPL_MODULE IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KOUT CHARACTER(LEN=*), INTENT(IN) :: CDLABEL INTEGER(KIND=JPIM) :: I, IMYPROC, INPROC, IRET, IOFFSET, II INTEGER(KIND=JPIM), PARAMETER :: JP_NPROFILE = 9 ! pls. consult ifsaux/utilities/getcurheap.c INTEGER(KIND=JPIM), PARAMETER :: ISIZE = JP_NPROFILE+1 INTEGER(KIND=JPIB) ILIMIT(ISIZE) INTEGER(KIND=JPIB) ICNT(ISIZE) REAL(KIND=JPRD), ALLOCATABLE :: ZSEND(:), ZRECV(:) INTEGER(KIND=JPIM), ALLOCATABLE :: ICOUNTS(:) CHARACTER(LEN=1) CLENV CHARACTER(LEN=80) CLTEXT(0:4) CALL GET_ENVIRONMENT_VARIABLE("EC_PROFILE_HEAP", CLENV) ! turn ON by export EC_PROFILE_HEAP=1 IF (KOUT >= 0 .AND. CLENV == '1') THEN IMYPROC = MPL_MYRANK() INPROC = MPL_NPROC() DO I=1,ISIZE ILIMIT(I) = I ! power of 10's ; pls. consult ifsaux/utilities/getcurheap.c ENDDO ALLOCATE(ZSEND(ISIZE)) ALLOCATE(ZRECV(ISIZE * INPROC)) ALLOCATE(ICOUNTS(INPROC)) CLTEXT(0) = "free()/DEALLOCATE -hits per byte range" CLTEXT(1) = "malloc()/ALLOCATE -hits per byte range" CLTEXT(2) = "Outstanding malloc()/ALLOCATE -hits per byte range" CLTEXT(3) = "Outstanding amount of malloc()/ALLOCATE -bytes per byte range" CLTEXT(4) = "Average amount of outstanding malloc()/ALLOCATE -bytes per byte range" DO II=0,4 ICNT(:) = 0 CALL PROFILE_HEAP_GET(ICNT, ISIZE, II, IRET) ZSEND(:) = 0 DO I=1,IRET ZSEND(I) = ICNT(I) ENDDO ZRECV(:) = -1 ICOUNTS(:) = ISIZE CALL MPL_GATHERV(ZSEND(:), KROOT=1, KRECVCOUNTS=ICOUNTS(:), & &PRECVBUF=ZRECV, CDSTRING='GETHEAPSTAT:') IF (IMYPROC == 1) THEN ! Not more than 132 columns, please :-) WRITE(KOUT,9000) TRIM(CLTEXT(II)),TRIM(CDLABEL), "Task", & & (ILIMIT(I),I=1,MIN(JP_NPROFILE,9)), "Larger" 9000 FORMAT(/,"Heap Utilization Profile (",A,"): ",A,& &/,126("="),& &//,(1X,A4,2X,9(:,2X,4X,"< 10^",I1),:,2X,A10)) WRITE(KOUT,9001) 9001 FORMAT(1X,4("="),2X,10(2X,10("="))/) IOFFSET = 0 DO I=1,INPROC ICNT(:) = ZRECV(IOFFSET+1:IOFFSET+ISIZE) WRITE(KOUT,'(i5,2x,(10(:,2x,i10)))') I,ICNT(:) IOFFSET = IOFFSET + ISIZE ENDDO ENDIF ENDDO IF (IMYPROC == 1) THEN WRITE(KOUT,'(/,a,/)') 'End of Heap Utilization Profile' ENDIF DEALLOCATE(ZSEND) DEALLOCATE(ZRECV) DEALLOCATE(ICOUNTS) ENDIF END SUBROUTINE GETHEAPSTAT fiat-ecmwf-2.0.0/src/fiat/system/getstk.c0000664000175000017500000000403015157200431020415 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include typedef long long int ll_t; static ll_t maxstack = 0; #if defined(LINUX) ll_t getvmpeak_() { ll_t virtmempeak = 0; FILE *fp = fopen("/proc/self/status","r"); if (fp) { char in[4096]; while (fgets(in,sizeof(in),fp) == in) { if (strncmp(in,"VmPeak:",7) == 0) { ll_t value; int nf = sscanf(in,"%*s %lld kB",&value); if (nf == 1) virtmempeak = value * (ll_t) 1024; break; } } fclose(fp); } return virtmempeak; } ll_t linux_getstackusage_() { ll_t stackused = 0; FILE *fp = fopen("/proc/self/status","r"); if (fp) { char in[4096]; while (fgets(in,sizeof(in),fp) == in) { if (strncmp(in,"VmStk:",6) == 0) { ll_t value; int nf = sscanf(in,"%*s %lld kB",&value); if (nf == 1) stackused = value * (ll_t) 1024; break; } } fclose(fp); } return stackused; } ll_t getstk_() { /* extern ll_t getstackusage_(); ll_t stackused = getstackusage_(); */ extern ll_t linux_getstackusage_(); ll_t stackused = linux_getstackusage_(); if (stackused > maxstack) maxstack = stackused; return stackused; } #else ll_t getstk_() { extern ll_t getstackusage_(); static ll_t init_stack = -1; ll_t stackused = 0; if (init_stack == -1) init_stack = getstackusage_(); stackused = getstackusage_() - init_stack; if (stackused > maxstack) maxstack = stackused; return stackused; } #endif /* Maximum stacksize encountered */ ll_t getmaxstk_() { ll_t stackused = getstk_(); if (stackused > maxstack) maxstack = stackused; return maxstack; } #if !defined(LINUX) ll_t getvmpeak_() { return 0L; } #endif fiat-ecmwf-2.0.0/src/fiat/system/sdl_mod.F900000664000175000017500000000674015157200431020663 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE SDL_MOD ! Interface between user applications and system-dependent intrinsic ! routines, provided by the computer vendors. ! All routines which wish to call these routines must contain: ! USE SDL_MOD ! Author : ! ------ ! 11-Apr-2005 R. El Khatib *METEO-FRANCE* ! 26-Apr-2006 S.T.Saarinen Dr.Hook trace, calls to EC_RAISE, Intel/ifort traceback USE EC_PARKIND ,ONLY : JPIM USE OML_MOD ,ONLY : OML_MY_THREAD USE MPL_MPI IMPLICIT NONE SAVE PRIVATE INTEGER, PARAMETER :: SIGABRT = 6 ! Hardcoded PUBLIC :: SDL_SRLABORT, SDL_DISABORT, SDL_TRACEBACK CONTAINS !----------------------------------------------------------------------------- SUBROUTINE SDL_TRACEBACK(KTID) USE YOMHOOK, ONLY: DR_HOOK_CALLTREE ! Purpose : ! ------- ! Traceback ! KTID : thread INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KTID INTEGER(KIND=JPIM) ITID CHARACTER(LEN=80) :: CLTRBK INTEGER(KIND=JPIM) :: IERROR,IPROC LOGICAL :: LMPI_INITIALIZED IPROC=1 CALL MPI_INITIALIZED(LMPI_INITIALIZED,IERROR) ! always thread safe, see standard ! IF( LMPI_INITIALIZED ) THEN CALL MPI_COMM_RANK(MPI_COMM_WORLD,IPROC,IERROR) ! always thread safe, see standard ! IPROC = IPROC+1 ! 1-based in IFS context ENDIF IF (PRESENT(KTID)) THEN ITID = KTID ELSE ITID = OML_MY_THREAD() ENDIF WRITE(0,'(A,I0,A,I0,A)') 'SDL_TRACEBACK [PROC=',IPROC,',THRD=',ITID,'] ...' CALL DR_HOOK_CALLTREE(ITID) #if defined(__INTEL_COMPILER) CALL INTEL_TRBK() ! runs LINUX_TRBK as well inside with environment EC_LINUX_TRBK=1 -- See gentrbk.F90 #else CALL LINUX_TRBK() CALL GDB_TRBK() ! needs environment GNUDEBUGGER=1 -- See linuxtrbk.c CALL DBX_TRBK() ! needs environment DBXDEBUGGER=1 -- See linuxtrbk.c #endif WRITE(0,'(A,I0,A,I0,A)') 'SDL_TRACEBACK [PROC=',IPROC,',THRD=',ITID,'] ... DONE' END SUBROUTINE SDL_TRACEBACK !----------------------------------------------------------------------------- SUBROUTINE SDL_SRLABORT ! Purpose : ! ------- ! To abort in serial environment CALL EC_RAISE(SIGABRT) STOP 'SDL_SRLABORT' END SUBROUTINE SDL_SRLABORT !----------------------------------------------------------------------------- SUBROUTINE SDL_DISABORT() ! Purpose : ! ------- ! To abort in distributed environment USE YOMHOOK, ONLY : LHOOK INTEGER(KIND=JPIM) :: IRETURN_CODE,IERROR CHARACTER(LEN=80) :: CLJOBID CHARACTER(LEN=80) :: CLTRBK #if defined(__INTEL_COMPILER) ! Intel compiler seems to hang in MPI_ABORT -- on all but the failing task(s) ! ... when linux trbk is used. REK IF (LHOOK) THEN CALL GET_ENVIRONMENT_VARIABLE("EC_LINUX_TRBK",CLTRBK) IF (CLTRBK=='1') THEN CALL GET_ENVIRONMENT_VARIABLE("SLURM_JOBID",CLJOBID) IF (CLJOBID /= ' ') THEN CALL SYSTEM("set -x; sleep 10; scancel --signal=TERM "//trim(CLJOBID)//" &") ENDIF ENDIF ENDIF #endif IRETURN_CODE=SIGABRT CALL MPI_ABORT(MPI_COMM_WORLD,IRETURN_CODE,IERROR) ! Tracked by the supervisor/process-damager (manager) -- KCOMM /= MPI_COMM_WORLD may hang as sub-communicator CALL EC_RAISE(SIGABRT) ! In case ever ends up here STOP 'SDL_DISABORT' END SUBROUTINE SDL_DISABORT !----------------------------------------------------------------------------- END MODULE SDL_MOD fiat-ecmwf-2.0.0/src/fiat/system/gethwm.c0000664000175000017500000000266015157200431020416 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include "getstatm.h" typedef long long int ll_t; static ll_t maxhwm = 0; #define gethwm gethwm_ // Cray linker: if you intend to link with -hstd_alloc and use Cray C compiler, then compile this file with -DSTD_ALLOC too #if !defined(STD_ALLOC) && (defined(_CRAYC) || defined(USE_TCMALLOC)) ll_t gethwm() { extern size_t get_tcmalloc_heap_size_(); return get_tcmalloc_heap_size_(); } #elif defined(LINUX) static ll_t basesize = -1; static size_t pagesize = 4096; ll_t gethwm() { struct statm sm; ll_t rc = 0; if (getstatm(&sm) == 0) { if (basesize < 0) { /* the very first time */ basesize = sm.size; pagesize = getpagesize(); if (pagesize <= 0) pagesize = 4096; } rc = (sm.size - basesize) * pagesize; if (rc > maxhwm) maxhwm = rc; } return rc; } #else ll_t gethwm() { ll_t rc = (ll_t)((uintptr_t)sbrk(0)); return rc; } #endif ll_t getmaxhwm_() { ll_t rc = gethwm_(); if (rc > maxhwm) maxhwm = rc; return maxhwm; } fiat-ecmwf-2.0.0/src/fiat/system/getrss.c0000664000175000017500000000200315157200431020421 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include "getstatm.h" typedef long long int ll_t; #define getrss getrss_ #if defined(LINUX) || defined(__APPLE__) static ll_t basesize = -1; static size_t pagesize = 4096; ll_t getrss() { struct statm sm; ll_t rc = 0; if (getstatm(&sm) == 0) { if (basesize < 0) { /* the very first time */ basesize = sm.resident; pagesize = getpagesize(); if (pagesize <= 0) pagesize = 4096; } rc = (sm.resident - basesize) * pagesize; } return rc; } #else ll_t getrss() { ll_t rc = (ll_t)((char *)sbrk(0) - (char *)0); return rc; } #endif fiat-ecmwf-2.0.0/src/fiat/system/getstackusage.c0000664000175000017500000000266215157200431021757 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ typedef long long int ll_t; typedef unsigned long long int ull_t; #if defined(LINUX) && defined(USE_MEMORY_MONITOR) #include #include ll_t getstackusage_() { ll_t rc = 0; static int dont_bother = 0; if (dont_bother) { rc = -2; } else { FILE *statfile = fopen ("/proc/self/stat", "r"); if (!statfile) { dont_bother = 1; rc = -1; } else { char dm[80]; ull_t startstack, kstkesp; /* stack start & ESP, the 28th and 29th columns, respectively */ /* Maybe not the brightest coding, but has to suffice for now (SS) */ int nelem = fscanf(statfile, "%s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %s %llu %llu ", dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,dm,&startstack,&kstkesp); if (nelem != 29) { dont_bother = 1; rc = -3; } else { rc = (ll_t)(startstack - kstkesp); } fclose(statfile); } } return rc; } #else ll_t getstackusage_() { return 0L; } #endif fiat-ecmwf-2.0.0/src/fiat/system/getmemstat.F900000664000175000017500000000447715157200431021421 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE GETMEMSTAT(KOUT, CDLABEL) USE EC_PARKIND ,ONLY : JPIM, JPRD, JPIB USE MPL_MODULE IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KOUT CHARACTER(LEN=*), INTENT(IN) :: CDLABEL INTEGER(KIND=JPIM) :: I, IMYPROC, INPROC, IOFFSET INTEGER(KIND=JPIM), PARAMETER :: JP_MEMKEYS = 5 ! pls. consult ifsaux/utilities/getmemvals.F90 INTEGER(KIND=JPIM) IMEMKEYS(JP_MEMKEYS) INTEGER(KIND=JPIB) IMEMVALS(JP_MEMKEYS) REAL(KIND=JPRD), ALLOCATABLE :: ZSEND(:), ZRECV(:) INTEGER(KIND=JPIM), ALLOCATABLE :: ICOUNTS(:) CHARACTER(LEN=1) CLENV CALL GET_ENVIRONMENT_VARIABLE("EC_PROFILE_MEM", CLENV) ! turn ON by export EC_PROFILE_MEM=1 IF (KOUT >= 0 .AND. CLENV == '1') THEN IMYPROC = MPL_MYRANK() INPROC = MPL_NPROC() ALLOCATE(ZSEND(JP_MEMKEYS)) ALLOCATE(ZRECV(JP_MEMKEYS * INPROC)) ALLOCATE(ICOUNTS(INPROC)) ! 1=MAXHEAP, 2=MAXRSS, 3=CURRENTHEAP, 5=MAXSTACK, 6=PAGING IMEMKEYS(:) = (/1, 2, 3, 5, 6/) CALL GETMEMVALS(JP_MEMKEYS, IMEMKEYS, IMEMVALS) ZSEND(:) = 0 DO I=1,JP_MEMKEYS ZSEND(I) = IMEMVALS(I) ENDDO ZRECV(:) = -1 ICOUNTS(:) = JP_MEMKEYS CALL MPL_GATHERV(ZSEND(:), KROOT=1, KRECVCOUNTS=ICOUNTS(:), & &PRECVBUF=ZRECV, CDSTRING='GETMEMSTAT:') IF (IMYPROC == 1) THEN WRITE(KOUT,9000) TRIM(CDLABEL) 9000 FORMAT(/,"Memory Utilization Information (in bytes) : ",a,/,79("="),//,& & " Task Max heapsize Max resident Current heap Max stack I/O-paging #",/,& & " ==== ============ ============ ============ ============ ============",//) IOFFSET = 0 DO I=1,INPROC IMEMVALS(:) = ZRECV(IOFFSET+1:IOFFSET+JP_MEMKEYS) WRITE(KOUT,'(I5,5(3X,I12))') I,IMEMVALS(:) IOFFSET = IOFFSET + JP_MEMKEYS ENDDO WRITE(KOUT,'(/,a,/)') 'End of Memory Utilization Information' ENDIF DEALLOCATE(ZSEND) DEALLOCATE(ZRECV) DEALLOCATE(ICOUNTS) CALL GETHEAPSTAT(KOUT, CDLABEL) ENDIF END SUBROUTINE GETMEMSTAT fiat-ecmwf-2.0.0/src/fiat/system/getstatm.c0000664000175000017500000000207115157200431020747 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include "getstatm.h" #if defined(LINUX) #include #include int getstatm(struct statm *sm) { static int dont_bother = 0; if (!sm || dont_bother) { return -2; } else { FILE *statfile = fopen ("/proc/self/statm", "r"); if (!statfile) { dont_bother = 1; return -1; } { int nelem = fscanf(statfile, "%d %d %d %d %d %d %d", &(sm->size), &(sm->resident), &(sm->shared), &(sm->trs), &(sm->drs), &(sm->lrs), &(sm->dt)); } fclose(statfile); } return 0; } #else int getstatm(struct statm *sm) { return -1; /* Not implemented */ } #endif fiat-ecmwf-2.0.0/src/fiat/system/getstatm.h0000664000175000017500000000161615157200431020760 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* statm format: (/proc/self/mem under LINUX) in units of pages (4096 bytes) size total program size resident size of in memory portions shared number of the pages that are shared trs number of pages that are 'code' drs number of pages of data/stack lrs number of pages of library dt number of dirty pages */ struct statm { int size; int resident; int shared; int trs; int drs; int lrs; int dt; }; extern int getstatm(struct statm *sm); fiat-ecmwf-2.0.0/src/fiat/util/0000775000175000017500000000000015157200431016404 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/util/xrd_getoptions.F900000664000175000017500000004675115157200431021751 0ustar alastairalastairMODULE XRD_GETOPTIONS !**** *XRD_GETOPTIONS* - Parse command lines options in long form ! Author. ! ------- ! Philippe Marguinaud *METEO FRANCE* ! Original : 11-09-2012 USE EC_PARKIND, ONLY: JPIM, JPRD, JPRM USE XRD_UNIX_ENV, ONLY: XRD_IARGC, XRD_GETARG, & XRD_BASENAME, XRD_COUNTWORDS, XRD_GETENV, & XRD_ISALPHA, XRD_ISDIGIT, XRD_EXIT IMPLICIT NONE INTERFACE GETOPTION MODULE PROCEDURE GETOPTIONS, GETOPTIONSL, & GETOPTIONI, GETOPTIONIL, & GETOPTIONR4, GETOPTIONR4L, & GETOPTIONR8, GETOPTIONR8L, & GETOPTIONB END INTERFACE !! @TODO : LIST WITH FIXED SIZE PUBLIC :: GETOPTION, INITOPTIONS, CHECKOPTIONS, ADDGROUP INTEGER, PARAMETER :: ARGSIZEMAX = 256 CHARACTER(LEN=ARGSIZEMAX), POINTER :: MYARGS(:) => NULL() LOGICAL(KIND=JPIM), POINTER :: CHECK_ARGS(:) => NULL() LOGICAL(KIND=JPIM) :: LHELP = .FALSE., LSHELL = .FALSE. CHARACTER(LEN=1056) :: MESSAGE_OPT = "" TYPE XRD_OPT CHARACTER(LEN=32) :: KEY, TYPE CHARACTER(LEN=1024) :: USE LOGICAL(KIND=JPIM) :: GROUP = .FALSE. END TYPE INTEGER(KIND=JPIM) :: NOPT_SEEN TYPE(XRD_OPT), POINTER :: OPT_SEEN(:) => NULL() PRIVATE CONTAINS SUBROUTINE ADDGROUP( USE ) CHARACTER(LEN=*), INTENT(IN) :: USE CALL INIT_OPT_SEEN() NOPT_SEEN = NOPT_SEEN + 1 CALL GROW_OPT_SEEN() OPT_SEEN(NOPT_SEEN)%GROUP = .TRUE. OPT_SEEN(NOPT_SEEN)%USE = USE END SUBROUTINE ADDGROUP CHARACTER(LEN=ARGSIZEMAX) FUNCTION GET_ENV_OPT( KEY ) CHARACTER(LEN=*), INTENT(IN) :: KEY CHARACTER(LEN=ARGSIZEMAX) :: KEY_ENV, VAL_ENV INTEGER(KIND=JPIM) :: I, N CHARACTER :: C KEY_ENV = KEY(3:) N = LEN(TRIM(KEY_ENV)) DO I = 1, N C = KEY_ENV(I:I) IF((.NOT.XRD_ISALPHA(C)) .AND. & (.NOT.XRD_ISDIGIT(C)) .AND. & (C .NE. '_' )) THEN KEY_ENV(I:I) = '_' ENDIF ENDDO VAL_ENV = "" CALL XRD_GETENV( 'XRD_OPT_'//TRIM(KEY_ENV), VAL_ENV ) !PRINT *, " KEY = ", TRIM(KEY_ENV), " VAL = ", TRIM(VAL_ENV) GET_ENV_OPT = VAL_ENV END FUNCTION GET_ENV_OPT SUBROUTINE MYGETARG( I, S ) INTEGER(KIND=JPIM), INTENT(IN) :: I CHARACTER(LEN=*), INTENT(OUT) :: S ! IF( I .LE. UBOUND( MYARGS, 1 ) ) THEN S = MYARGS(I) ELSE S = "" ENDIF END SUBROUTINE MYGETARG INTEGER FUNCTION MYIARGC() INTEGER :: N N = UBOUND( MYARGS, 1 ) MYIARGC = N END FUNCTION MYIARGC SUBROUTINE ADDOPT_SHELL( KEY, TYPE, MND, USE ) CHARACTER*(*), INTENT(IN) :: KEY, TYPE, USE LOGICAL(KIND=JPIM), INTENT(IN) :: MND OPTIONAL :: USE, MND ! CHARACTER(LEN=ARGSIZEMAX) :: STR INTEGER :: NN, N, N1, I1, I2, K CHARACTER(LEN=ARGSIZEMAX), POINTER :: MYARGS1(:) MYARGS1 => NULL() IF( PRESENT( USE ) ) WRITE( *, '("> ",A)' ) TRIM(USE) IF( PRESENT( MND ) ) THEN IF( MND ) WRITE( *, * ) "[MANDATORY]" ENDIF WRITE( *, * ) "* OPTION: [", TYPE, "]", " ", TRIM(KEY) READ( *, '(A)' ) STR ! PRINT *, "STR = ",TRIM(STR) IF( TRIM(STR) .NE. "" ) THEN IF( TYPE .EQ. 'FLAG' ) THEN NN = 0 ELSE NN = XRD_COUNTWORDS( STR ) ENDIF N = UBOUND( MYARGS, 1 ) N1 = N + NN + 1 ! ! REALLOC MYARGS ! ALLOCATE( MYARGS1(0:N1) ) MYARGS1(0:N) = MYARGS(0:N) DEALLOCATE( MYARGS ) MYARGS => MYARGS1 MYARGS(N+1) = KEY ! ! PARSE ARGUMENT LIST ! IF( TYPE .NE. 'FLAG' ) THEN K = 1 I1 = 1 LOOP_I1 : DO DO IF( I1 .GT. LEN(STR)) EXIT LOOP_I1 IF( STR(I1:I1) .NE. ' ' ) EXIT I1 = I1+1 ENDDO I2 = I1+1 DO IF( I2 .GT. LEN(STR)) EXIT IF( STR(I2:I2) .EQ. ' ' ) EXIT I2 = I2+1 ENDDO !PRINT *, I1, I2 MYARGS(N+1+K) = STR(I1:I2-1) !PRINT *, K, TRIM(MYARGS(N+1+K)) K = K+1 I1 = I2+1 ENDDO LOOP_I1 ENDIF ENDIF END SUBROUTINE ADDOPT_SHELL SUBROUTINE INIT_OPT_SEEN() IF( .NOT. ASSOCIATED( OPT_SEEN ) ) THEN NOPT_SEEN = 0 ALLOCATE( OPT_SEEN( 32 ) ) ENDIF END SUBROUTINE INIT_OPT_SEEN SUBROUTINE GROW_OPT_SEEN() INTEGER(KIND=JPIM) :: N TYPE(XRD_OPT), POINTER :: OPT_SEEN1(:) N = SIZE( OPT_SEEN ) IF( NOPT_SEEN .GE. N ) THEN ! REALLOC DATA OPT_SEEN1 => OPT_SEEN ALLOCATE( OPT_SEEN( 2 * N ) ) OPT_SEEN(1:NOPT_SEEN) = OPT_SEEN1(1:NOPT_SEEN) DEALLOCATE( OPT_SEEN1 ) ENDIF END SUBROUTINE GROW_OPT_SEEN SUBROUTINE ADDOPT( KEY, TYPE, USE ) CHARACTER*(*), INTENT(IN) :: KEY, TYPE, USE OPTIONAL :: USE CALL INIT_OPT_SEEN() NOPT_SEEN = NOPT_SEEN + 1 CALL GROW_OPT_SEEN() OPT_SEEN(NOPT_SEEN)%KEY = KEY OPT_SEEN(NOPT_SEEN)%TYPE = TYPE IF( PRESENT( USE ) ) THEN OPT_SEEN(NOPT_SEEN)%USE = USE ELSE OPT_SEEN(NOPT_SEEN)%USE = '' ENDIF END SUBROUTINE ADDOPT SUBROUTINE INITOPTIONS( CDMESSAGE, KOPTMIN, KOPTMAX, CDARGS ) CHARACTER(LEN=*), OPTIONAL, INTENT (IN) :: CDMESSAGE INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: KOPTMIN, KOPTMAX CHARACTER (LEN=*), OPTIONAL, INTENT (IN) :: CDARGS (0:) INTEGER(KIND=JPIM) :: N, I INTEGER(KIND=JPIM) :: IOPTMIN, IOPTMAX CHARACTER*32 :: STR IF (PRESENT (CDARGS)) THEN N = UBOUND (CDARGS, 1) ELSE N = XRD_IARGC() ENDIF IOPTMIN = 0 IOPTMAX = N IF (PRESENT (KOPTMIN)) IOPTMIN = KOPTMIN IF (PRESENT (KOPTMAX)) IOPTMAX = KOPTMAX N = IOPTMAX-IOPTMIN ALLOCATE( MYARGS(0:N) ) DO I = 0, N IF (PRESENT (CDARGS)) THEN MYARGS(I) = CDARGS (IOPTMIN+I) ELSE CALL XRD_GETARG( IOPTMIN+I, MYARGS(I) ) ENDIF ENDDO IF( PRESENT( CDMESSAGE ) ) THEN MESSAGE_OPT = CDMESSAGE ELSE MESSAGE_OPT = "" ENDIF IF( N .EQ. 1 ) THEN CALL MYGETARG( 1_JPIM, STR ) IF( TRIM( STR ) .EQ. '--help' ) THEN LHELP = .TRUE. RETURN ELSE IF( TRIM( STR ) .EQ. '--shell' ) THEN LSHELL = .TRUE. RETURN ENDIF ENDIF LHELP = .FALSE. ALLOCATE( CHECK_ARGS( N ) ) CHECK_ARGS = .FALSE. END SUBROUTINE INITOPTIONS SUBROUTINE CHECKOPTIONS() INTEGER(KIND=JPIM) :: I, N, IS, NS, KS CHARACTER(LEN=ARGSIZEMAX) :: OPT, PROG LOGICAL(KIND=JPIM) :: PB CHARACTER(LEN=10) :: FMT CHARACTER(LEN=110) :: BUF CALL MYGETARG( 0_JPIM, PROG ) IF( LHELP ) THEN PRINT *, "PROGRAM: ", TRIM(XRD_BASENAME( PROG )) IF( TRIM(MESSAGE_OPT) .NE. "" ) THEN NS = LEN(MESSAGE_OPT) DO IS = 1, NS / 96 KS = LEN( TRIM(MESSAGE_OPT(1+(IS-1)*96:IS*96)) ) IF( KS .GT. 0 ) THEN IF( IS .EQ. 1 ) THEN WRITE( *, '(" ")', ADVANCE = 'NO' ) ELSE WRITE( *, '(" > ")', ADVANCE = 'NO' ) ENDIF WRITE( FMT, '("(A",I2,")")' ) KS WRITE( *, FMT ) TRIM(MESSAGE_OPT(1+(IS-1)*96:IS*96)) ENDIF ENDDO ENDIF DO I = 1, NOPT_SEEN IF(OPT_SEEN(I)%GROUP) THEN WRITE( *, * ) IF( TRIM(OPT_SEEN(I)%USE) .NE. "" ) & WRITE( *, * ) '* '//TRIM(OPT_SEEN(I)%USE) CYCLE ENDIF BUF = "" WRITE( BUF, '(A32," = ",A15)' ) & TRIM(OPT_SEEN(I)%KEY), & TRIM(OPT_SEEN(I)%TYPE) IF( TRIM(OPT_SEEN(I)%USE) .NE. '' ) THEN NS = LEN( OPT_SEEN(I)%USE) DO IS = 1, NS / 48 KS = LEN(TRIM(OPT_SEEN(I)%USE(1+(IS-1)*48:IS*48))) IF( KS .GT. 0 ) THEN IF( IS .EQ. 1 ) THEN BUF = TRIM(BUF)//" : "//TRIM(OPT_SEEN(I)%USE(1+(IS-1)*48:IS*48)) ELSE ! 000000000011111111112222222222333333333344444444445555555555 ! 012345678901234567890123456789012345678901234567890123456789 BUF = " > "& //TRIM(OPT_SEEN(I)%USE(1+(IS-1)*48:IS*48)) ENDIF WRITE( *, '(A120)' ) BUF ENDIF ENDDO ELSE WRITE( *, '(A120)' ) BUF WRITE( *, * ) ENDIF ENDDO STOP ELSE IF( ASSOCIATED( CHECK_ARGS ) ) THEN N = SIZE( CHECK_ARGS ) PB = .FALSE. DO I = 1, N IF( .NOT. CHECK_ARGS(I) ) THEN CALL MYGETARG( I, OPT ) IF( OPT(1:2) .EQ. '--' ) THEN PRINT *, 'INVALID OPTION: ', TRIM(OPT) PB = .TRUE. CHECK_ARGS(I) = .TRUE. ENDIF ENDIF ENDDO DO I = 1, N IF( .NOT. CHECK_ARGS(I) ) THEN CALL MYGETARG( I, OPT ) PRINT *, 'GARBAGE IN OPTIONS:`', TRIM(OPT), "'" PB = .TRUE. EXIT ENDIF ENDDO IF( PB ) CALL XRD_EXIT(1_JPIM) DEALLOCATE( CHECK_ARGS ) ELSE IF( LSHELL ) THEN OPEN( 77, FILE = TRIM(PROG)//'.sh', FORM = 'FORMATTED' ) WRITE( 77, '("#!/bin/sh")' ) WRITE( 77, * ) WRITE( 77, '(A)', ADVANCE = 'NO' ) TRIM(PROG) N = UBOUND( MYARGS, 1 ) DO I = 1, N IF( MYARGS(I) .EQ. '--shell' ) CYCLE IF( MYARGS(I)(1:2) .EQ. '--' ) THEN WRITE( 77, '(" \")' ) WRITE( 77, '(" ")', ADVANCE = 'NO' ) ENDIF WRITE( 77, '(" ",A)', ADVANCE = 'NO' ) TRIM(MYARGS(I)) ENDDO WRITE( 77, * ) CLOSE(77) ENDIF IF( ASSOCIATED( OPT_SEEN ) ) DEALLOCATE( OPT_SEEN ) IF( ASSOCIATED( MYARGS ) ) DEALLOCATE( MYARGS ) END SUBROUTINE CHECKOPTIONS SUBROUTINE CHECK_MND( KEY, MND, USE ) CHARACTER(LEN=*), INTENT(IN) :: KEY CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND ! CHARACTER(LEN=ARGSIZEMAX) :: PROG IF( PRESENT( MND ) ) THEN IF( MND ) THEN CALL MYGETARG( 0_JPIM, PROG ) WRITE( *, '("PROGRAM: ",(A))' ) TRIM( PROG ) WRITE( *, '("ERROR: OPTION `",(A),"'' IS MANDATORY")' ) TRIM( KEY ) IF( PRESENT( USE ) ) WRITE( *, '(" ",(A)," : ",(A))' ) TRIM( KEY ), TRIM( USE ) CALL XRD_EXIT(1_JPIM) ENDIF ENDIF END SUBROUTINE CHECK_MND SUBROUTINE FINDARGINDEX( KEY, I, N ) CHARACTER(LEN=*), INTENT(IN) :: KEY INTEGER(KIND=JPIM), INTENT(OUT) :: I, N CHARACTER(LEN=ARGSIZEMAX) :: ARG N = MYIARGC() DO I = 1, N CALL MYGETARG( I, ARG ) IF( TRIM( ARG ) .EQ. TRIM( KEY ) ) RETURN ENDDO I = -1_JPIM END SUBROUTINE FINDARGINDEX SUBROUTINE FINDNEXTARGINDEX( I, J ) INTEGER(KIND=JPIM), INTENT(IN) :: I INTEGER(KIND=JPIM), INTENT(OUT) :: J ! CHARACTER(LEN=ARGSIZEMAX) :: ARG INTEGER(KIND=JPIM) :: N N = MYIARGC() DO J = I+1, N CALL MYGETARG( J, ARG ) IF( ARG(1:2) .EQ. '--' ) EXIT ENDDO END SUBROUTINE FINDNEXTARGINDEX SUBROUTINE GETOPTIONS( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY CHARACTER(LEN=*), INTENT(INOUT) :: VAL LOGICAL(KIND=JPIM), INTENT(IN), OPTIONAL :: MND CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: USE ! INTEGER(KIND=JPIM) :: I, N CHARACTER(LEN=ARGSIZEMAX) :: ARG LOGICAL(KIND=JPIM) :: LSHELL1 LOGICAL(KIND=JPIM) :: FOUND LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'STRING', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'STRING', MND, USE ) ENDIF CALL FINDARGINDEX( KEY, I, N ) FOUND = ( 0 .LT. I ) .AND. ( I .LT. N ) IF( FOUND ) THEN IF( ASSOCIATED( CHECK_ARGS ) ) THEN CHECK_ARGS(I) = .TRUE. CHECK_ARGS(I+1) = .TRUE. ENDIF CALL MYGETARG( I+1_JPIM, VAL ) ELSE ARG = GET_ENV_OPT( KEY ) FOUND = ARG .NE. "" IF( FOUND ) VAL = ARG ENDIF IF( .NOT. FOUND ) & CALL CHECK_MND( KEY, MND, USE ) LSHELL = LSHELL1 END SUBROUTINE GETOPTIONS SUBROUTINE GETOPTIONI( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY INTEGER(KIND=JPIM), INTENT(INOUT) :: VAL LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! CHARACTER(LEN=ARGSIZEMAX) :: SVAL INTEGER :: ERR LOGICAL(KIND=JPIM) :: LSHELL1 LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'INTEGER', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'INTEGER', MND, USE ) ENDIF SVAL = "" CALL GETOPTIONS( KEY, SVAL, MND, USE ) IF( TRIM( SVAL ) .NE. "" ) THEN READ( SVAL, *, IOSTAT = ERR ) VAL IF( ERR .NE. 0 ) THEN PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) CALL XRD_EXIT(1_JPIM) ENDIF ENDIF LSHELL = LSHELL1 END SUBROUTINE GETOPTIONI SUBROUTINE GETOPTIONR4( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY REAL(KIND=JPRM), INTENT(INOUT) :: VAL LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! CHARACTER(LEN=ARGSIZEMAX) :: SVAL INTEGER :: ERR LOGICAL(KIND=JPIM) :: LSHELL1 LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'REAL', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'REAL', MND, USE ) ENDIF SVAL = "" CALL GETOPTIONS( KEY, SVAL, MND, USE ) IF( TRIM( SVAL ) .NE. "" ) THEN READ( SVAL, *, IOSTAT = ERR ) VAL IF( ERR .NE. 0 ) THEN PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) CALL XRD_EXIT(1_JPIM) ENDIF ENDIF LSHELL = LSHELL1 END SUBROUTINE GETOPTIONR4 SUBROUTINE GETOPTIONR8( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY REAL(KIND=JPRD), INTENT(INOUT) :: VAL LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! CHARACTER(LEN=ARGSIZEMAX) :: SVAL INTEGER :: ERR LOGICAL(KIND=JPIM) :: LSHELL1 LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'REAL', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'REAL', MND, USE ) ENDIF SVAL = "" CALL GETOPTIONS( KEY, SVAL, MND, USE ) IF( TRIM( SVAL ) .NE. "" ) THEN READ( SVAL, *, IOSTAT = ERR ) VAL IF( ERR .NE. 0 ) THEN PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) CALL XRD_EXIT(1_JPIM) ENDIF ENDIF LSHELL = LSHELL1 END SUBROUTINE GETOPTIONR8 SUBROUTINE READASLFROMSTRING( VAL, SVAL ) CHARACTER(LEN=*), INTENT(OUT) :: VAL(:) CHARACTER(LEN=*), INTENT(IN) :: SVAL ! INTEGER(KIND=JPIM) :: I, J, K, N N = LEN( SVAL ) I = 1 K = 1 DO1 : DO DO IF( I .GT. N ) EXIT DO1 IF( SVAL(I:I) .NE. ' ' ) EXIT I = I + 1 ENDDO J = I DO IF( J .GT. N ) EXIT IF( SVAL(J:J) .EQ. ' ' ) EXIT J = J + 1 ENDDO VAL(K) = SVAL(I:J-1) I = J K = K + 1 ENDDO DO1 END SUBROUTINE READASLFROMSTRING SUBROUTINE READSLFROMSTRING( VAL, SVAL ) CHARACTER(LEN=*), POINTER :: VAL(:) CHARACTER(LEN=*), INTENT(IN) :: SVAL ! INTEGER(KIND=JPIM) :: N N = XRD_COUNTWORDS( SVAL ) ALLOCATE( VAL( N ) ) CALL READASLFROMSTRING( VAL, SVAL ) END SUBROUTINE READSLFROMSTRING SUBROUTINE READSLFROMFILE( VAL, SVAL ) CHARACTER(LEN=*), POINTER :: VAL(:) CHARACTER(LEN=*), INTENT(IN) :: SVAL ! INTEGER(KIND=JPIM) :: K, N INTEGER(KIND=JPIM) :: IOERR CHARACTER(LEN=4096) :: BUFFER OPEN( 77, FILE = TRIM(SVAL), FORM = 'FORMATTED', STATUS = 'OLD', IOSTAT = IOERR ) IF( IOERR .NE. 0 ) THEN PRINT '( "COULD NOT OPEN ",A, " FOR READING")', TRIM(SVAL) CALL XRD_EXIT(1_JPIM) ENDIF N = 0_JPIM DO READ( 77, '(A)', END = 500 ) BUFFER N = N + XRD_COUNTWORDS( BUFFER ) ENDDO 500 CONTINUE REWIND( 77 ) ALLOCATE( VAL( N ) ) K = 1 DO READ( 77, '(A)', END = 600 ) BUFFER N = XRD_COUNTWORDS( BUFFER ) CALL READASLFROMSTRING( VAL(K:K+N-1), BUFFER ) K = K + N ENDDO 600 CONTINUE CLOSE( 77 ) END SUBROUTINE READSLFROMFILE SUBROUTINE GETOPTIONSL( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY CHARACTER(LEN=*), POINTER :: VAL(:) LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! INTEGER(KIND=JPIM) :: I, J, K, N CHARACTER(LEN=ARGSIZEMAX) :: ARG CHARACTER(LEN=ARGSIZEMAX) :: SVAL LOGICAL(KIND=JPIM) :: LSHELL1 LOGICAL(KIND=JPIM) :: FOUND LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'STRING-LIST', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'STRING-LIST', MND, USE ) ENDIF CALL FINDARGINDEX( KEY, I, N ) FOUND = I >= 0 IF( FOUND ) THEN CALL FINDNEXTARGINDEX( I, J ) ALLOCATE( VAL( J - I - 1 ) ) IF( ASSOCIATED( CHECK_ARGS ) ) & CHECK_ARGS(I) = .TRUE. DO K = I+1, J-1 IF( ASSOCIATED( CHECK_ARGS ) ) & CHECK_ARGS(K) = .TRUE. CALL MYGETARG( K, ARG ) IF ((I+1.EQ.J-1) .AND. (ARG(1:7).EQ.'file://')) THEN DEALLOCATE (VAL) ARG = ARG(8:) CALL READSLFROMFILE( VAL, ARG ) ELSE VAL(K-I) = ARG ENDIF ENDDO ENDIF IF(.NOT. FOUND) THEN SVAL = GET_ENV_OPT( KEY ) FOUND = SVAL .NE. "" IF( FOUND ) & CALL READSLFROMSTRING( VAL, SVAL ) ENDIF IF( .NOT. FOUND ) & CALL CHECK_MND( KEY, MND, USE ) LSHELL = LSHELL1 END SUBROUTINE GETOPTIONSL SUBROUTINE GETOPTIONIL( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY INTEGER(KIND=JPIM), POINTER :: VAL(:) LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! CHARACTER(LEN=ARGSIZEMAX), POINTER :: SVAL(:) INTEGER(KIND=JPIM) :: I, N INTEGER :: ERR LOGICAL(KIND=JPIM) :: LSHELL1 NULLIFY (SVAL) LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'INTEGER-LIST', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'INTEGER-LIST', MND, USE ) ENDIF CALL GETOPTIONSL( KEY, SVAL, MND, USE ) IF( .NOT. ASSOCIATED( SVAL ) ) GOTO 999 N = SIZE( SVAL ) ALLOCATE( VAL( N ) ) DO I = 1, N READ( SVAL( I ), *, IOSTAT = ERR ) VAL( I ) IF( ERR .NE. 0 ) THEN PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) CALL XRD_EXIT(1_JPIM) ENDIF ENDDO DEALLOCATE( SVAL ) 999 CONTINUE LSHELL = LSHELL1 END SUBROUTINE GETOPTIONIL SUBROUTINE GETOPTIONR4L( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY REAL(KIND=JPRM), POINTER :: VAL(:) LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! CHARACTER(LEN=ARGSIZEMAX), POINTER :: SVAL(:) INTEGER(KIND=JPIM) :: I, N INTEGER :: ERR LOGICAL(KIND=JPIM) :: LSHELL1 NULLIFY (SVAL) LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'REAL-LIST', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'REAL-LIST', MND, USE ) ENDIF CALL GETOPTIONSL( KEY, SVAL, MND, USE ) IF( .NOT. ASSOCIATED( SVAL ) ) GOTO 999 N = SIZE( SVAL ) ALLOCATE( VAL( N ) ) DO I = 1, N READ( SVAL( I ), *, IOSTAT = ERR ) VAL( I ) IF( ERR .NE. 0 ) THEN PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) CALL XRD_EXIT(1_JPIM) ENDIF ENDDO DEALLOCATE( SVAL ) 999 CONTINUE LSHELL = LSHELL1 END SUBROUTINE GETOPTIONR4L SUBROUTINE GETOPTIONR8L( KEY, VAL, MND, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY REAL(KIND=JPRD), POINTER :: VAL(:) LOGICAL(KIND=JPIM), OPTIONAL, INTENT(IN) :: MND CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! CHARACTER(LEN=ARGSIZEMAX), POINTER :: SVAL(:) INTEGER(KIND=JPIM) :: I, N INTEGER :: ERR LOGICAL(KIND=JPIM) :: LSHELL1 NULLIFY (SVAL) LSHELL1 = LSHELL IF( LHELP ) THEN CALL ADDOPT( KEY, 'REAL-LIST', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'REAL-LIST', MND, USE ) ENDIF CALL GETOPTIONSL( KEY, SVAL, MND, USE ) IF( .NOT. ASSOCIATED( SVAL ) ) GOTO 999 N = SIZE( SVAL ) ALLOCATE( VAL( N ) ) DO I = 1, N READ( SVAL( I ), *, IOSTAT = ERR ) VAL( I ) IF( ERR .NE. 0 ) THEN PRINT *, "ERROR WHILE PARSING OPTION "//TRIM(KEY) CALL XRD_EXIT(1_JPIM) ENDIF ENDDO DEALLOCATE( SVAL ) 999 CONTINUE LSHELL = LSHELL1 END SUBROUTINE GETOPTIONR8L SUBROUTINE GETOPTIONB( KEY, VAL, USE ) ! CHARACTER(LEN=*), INTENT(IN) :: KEY LOGICAL(KIND=JPIM), INTENT(INOUT) :: VAL CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: USE ! LOGICAL(KIND=JPIM) :: LSHELL1 LOGICAL(KIND=JPIM) :: FOUND CHARACTER(LEN=ARGSIZEMAX) :: SVAL INTEGER(KIND=JPIM) :: I, N LSHELL1 = LSHELL VAL = .FALSE. IF( LHELP ) THEN CALL ADDOPT( KEY, 'FLAG', USE ) RETURN ELSE IF( LSHELL ) THEN LSHELL = .FALSE. CALL ADDOPT_SHELL( KEY, 'FLAG', .FALSE._JPIM, USE ) ENDIF CALL FINDARGINDEX( KEY, I, N ) FOUND = I > 0 IF( FOUND .AND. ASSOCIATED( CHECK_ARGS ) ) THEN CHECK_ARGS(I) = .TRUE. VAL = .TRUE. ELSE SVAL = GET_ENV_OPT( KEY ) IF( SVAL .NE. "" ) & READ( SVAL, * ) VAL ENDIF LSHELL = LSHELL1 END SUBROUTINE GETOPTIONB END MODULE XRD_GETOPTIONS fiat-ecmwf-2.0.0/src/fiat/util/internal/0000775000175000017500000000000015157200431020220 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/util/internal/ecmwf_transfer.c0000664000175000017500000000140615157200431023372 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ecmwf_transfer.c */ #include #include #include /* Used in module strhandler (stransfer) */ void ecmwf_transfer_(void *out, const int *Len_out, const void *in, const int *Len_in /* Possible hidden argument (not referred) */ , int Sta_lin) { int len = *Len_out; if (*Len_in < len) len = *Len_in; if (len > 0) memcpy(out,in,len); } fiat-ecmwf-2.0.0/src/fiat/util/internal/ecmpi_version.c0000664000175000017500000000337115157200431023232 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include extern int MPI_Get_version(int *version, int *subversion); extern int MPI_Get_library_version(char *version, int *resultlen); /* Depending on MPI version these function may not exist -- thus weak definition */ #pragma weak MPI_Get_version #pragma weak MPI_Get_library_version void ecmpi_version_(int *version, int *subversion, char *library_version, int *resultlen /* hidden length */ ,const int len_library_version) { int slen = 0; if (version && subversion) { if (MPI_Get_version) { (void) MPI_Get_version(version, subversion); } else { *version = 0; *subversion = 0; } } if (library_version && len_library_version > 0) { if (MPI_Get_library_version) { char s[4096]; (void) MPI_Get_library_version(s,&slen); if (slen > len_library_version) slen = len_library_version; while (slen > 0 && (s[slen-1] == '\n' || s[slen-1] == '\0')) slen--; memset(library_version,' ',len_library_version); if (slen > 0) memcpy(library_version,s,slen); } } if (resultlen) *resultlen = slen; } void ecmpi_version(int *version, int *subversion, char *library_version, int *resultlen /* hidden length */ ,const int len_library_version) { ecmpi_version_(version,subversion,library_version,resultlen,len_library_version); } fiat-ecmwf-2.0.0/src/fiat/util/internal/ecomp_version.c0000664000175000017500000000252415157200431023237 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ void ecomp_version_(int *version, int *subversion, int *openmp) { extern void get_openmp_(int *); if (version && subversion && openmp) { *version = 0; *subversion = 0; get_openmp_(openmp); // See Fortran file run_fortran_omp_parallel.F90 if (*openmp >= 200505 && *openmp < 200805) { /* v2.5 */ *version = 2; *subversion = 5; } else if (*openmp >= 200805 && *openmp < 201107) { /* v3.0 */ *version = 3; *subversion = 0; } else if (*openmp >= 201107 && *openmp < 201307) { /* v3.1 */ *version = 3; *subversion = 1; } else if (*openmp >= 201307 && *openmp < 201511) { /* v4.0 */ *version = 4; *subversion = 0; } else if (*openmp >= 201511) { /* v4.5 */ *version = 4; *subversion = 5; } } } void ecomp_version(int *version, int *subversion, int *openmp) { ecomp_version_(version,subversion,openmp); } fiat-ecmwf-2.0.0/src/fiat/util/internal/raise.h0000664000175000017500000000135315157200431021476 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef _RAISE_H_ #define _RAISE_H_ /* raise.h */ #include #include #include #include #include "abor1.h" #define RAISE(x) { \ if ((x) == SIGABRT) { \ ABOR1("*** Fatal error; aborting (SIGABRT) ..."); \ _exit(1); /* Should never end up here */ \ } \ else raise(x); \ } #endif /* _RAISE_H_ */ fiat-ecmwf-2.0.0/src/fiat/util/internal/julian.h0000664000175000017500000005520415157200431021661 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* Author: Dr. Umberto Modigliani, User Support. Modified by Willem Deconinck to be more portable using standard integers. - Originally this file was part of eclib - Then was ifsaux/eclite/julian.h - Now part of fiat */ #ifndef EC_DATETIME_C #error This file is only to be included by ec_datetime.c #endif #ifndef __julian_H__ #define __julian_H__ #include #include #include #include #include #include #include #include #include #ifdef __cplusplus extern "C" { #define INLINE inline #else #define INLINE #endif static void err_msg(const char *fmt, ...); /******************************* * Macros *******************************/ #define ERR_MAXLINE 4096 /* max line length */ #define leap(y) (((y) % 4 == 0 && (y) % 100 != 0) || (y) % 400 == 0) /******************************* * Types *******************************/ typedef int32_t exit_t; /* typedef unsigned long int _uint32_t; typedef unsigned short int _uint16_t; */ typedef struct iso_date_str { int32_t julian; int32_t seconds; } mydate_t; typedef struct date_str { int32_t day; int32_t month; int32_t year; } yyyymmdd_t; typedef struct hms_str { int32_t hour; int32_t min; int32_t sec; } hhmmss_t; /******************************* * Externals *******************************/ /* None */ /******************************* * Prototypes *******************************/ /* * * Internal routines: set static * */ static exit_t addDays(const yyyymmdd_t *const date_ptr, const int32_t days, yyyymmdd_t *const new_date_ptr); static exit_t addHours(const yyyymmdd_t *const date_ptr, const hhmmss_t *const hms_ptr, const int32_t hours, yyyymmdd_t *const new_date_ptr, hhmmss_t *const new_hms_ptr); static exit_t addMinutes(const yyyymmdd_t *const date_ptr, const hhmmss_t *const hms_ptr, const int32_t minutes, yyyymmdd_t *const new_date_ptr, hhmmss_t *const new_hms_ptr); static exit_t addSeconds(const yyyymmdd_t *const date_ptr, const hhmmss_t *const hms_ptr, const int32_t seconds, yyyymmdd_t *const new_date_ptr, hhmmss_t *const new_hms_ptr); static exit_t dateMinusDate(const yyyymmdd_t *const date1_ptr, const yyyymmdd_t *const date2_ptr, int32_t *const days_ptr); static exit_t hour_dateMinusDate(const yyyymmdd_t *const date1_ptr, const hhmmss_t *const hms1_ptr, const yyyymmdd_t *const date2_ptr, const hhmmss_t *const hms2_ptr, int32_t *const hours_ptr); static exit_t min_dateMinusDate(const yyyymmdd_t *const date1_ptr, const hhmmss_t *const hms1_ptr, const yyyymmdd_t *const date2_ptr, const hhmmss_t *const hms2_ptr, int32_t *const minutes_ptr); static exit_t sec_dateMinusDate(const yyyymmdd_t *const date1_ptr, const hhmmss_t *const hms1_ptr, const yyyymmdd_t *const date2_ptr, const hhmmss_t *const hms2_ptr, int32_t *const seconds_ptr); static exit_t is_hms(const hhmmss_t *const hms_ptr); static exit_t is_date(const yyyymmdd_t *const date_ptr); static exit_t _addHours(const mydate_t *const fulldate_ptr, const int32_t hours, mydate_t *const new_fulldate_ptr); static exit_t _addMinutes(const mydate_t *const fulldate_ptr, const int32_t minutes, mydate_t *const new_fulldate_ptr); static exit_t _addSeconds(const mydate_t *const fulldate_ptr, const int32_t seconds, mydate_t *const new_fulldate_ptr); static exit_t julianToDate(const int32_t julian, yyyymmdd_t *const date_ptr); static exit_t dateToJulian(const yyyymmdd_t *const date_ptr, int32_t *const julian); static exit_t secondsToHms(const int32_t seconds, hhmmss_t *const hms_ptr); static exit_t hmsToSeconds(const hhmmss_t *const hms_ptr, int32_t *const seconds); static exit_t centuryToDate(const int32_t century, yyyymmdd_t *date_ptr); static exit_t dateToCentury(const yyyymmdd_t *const date_ptr, int32_t *const century_ptr); static exit_t dateToYearday(const yyyymmdd_t *const date_ptr, int32_t *const yearday_ptr); static exit_t yeardayToDate(const int32_t yearday, const int32_t year, yyyymmdd_t *date_ptr); /******************************* * Constants *******************************/ static const int32_t month_len[] = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; static const int32_t MJDSHIFT = 0; static const int32_t CENTURYSHIFT = 2415021; /* static const int32_t MJDSHIFT = 2400000; static const int32_t CENTURYSHIFT = 15021; */ static const int64_t JULIAN_MIN = 0LL; static const int32_t EC_OK = 0; static const int32_t EC_FALSE = -1; static const int32_t EC_WRGOPT = -2; static const int32_t EC_WRGPAR = -3; static const int32_t EC_WRGLEN = -4; static const int32_t EC_DATELEN = -5; static const int32_t EC_DATEFMT = -6; static const int32_t EC_DATEINV = -7; static const int32_t EC_TIMEINV = -8; static const int32_t EC_NAN = -9; static const int32_t EC_RANGE = -10; static const int32_t YEAR_MIN = 0; static const int32_t YEAR_MAX = 9999; static const int32_t SEC_MIN = 60; static const int32_t SEC_HOUR = 3600; static const int32_t SEC_DAY = 86400; static const int32_t MIN_HOUR = 60; static const int32_t MIN_DAY = 1440; static const int32_t HOUR_DAY = 24; /******************************* * Functions *******************************/ static exit_t dateMinusDate(const yyyymmdd_t *const date1_ptr, const yyyymmdd_t *const date2_ptr, int32_t *const days_ptr) { int32_t julian1 = 0, julian2 = 0; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date1_ptr, &julian1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = dateToJulian(date2_ptr, &julian2) ) != EC_OK) { return (exit_status); } *days_ptr = (julian1 - julian2); return (EC_OK); } /* dateMinusDate */ static exit_t hour_dateMinusDate(const yyyymmdd_t *const date1_ptr, const hhmmss_t *const hms1_ptr, const yyyymmdd_t *const date2_ptr, const hhmmss_t *const hms2_ptr, int32_t *const hours_ptr) { int32_t julian1 = 0, julian2 = 0; int32_t second1 = 0, second2 = 0; int64_t hours = 0; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date1_ptr, &julian1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = dateToJulian(date2_ptr, &julian2) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms1_ptr, &second1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms2_ptr, &second2) ) != EC_OK) { return (exit_status); } hours = (julian1 - julian2) * (int64_t) HOUR_DAY + (second1 - second2) / SEC_HOUR ; if ( hours > INT32_MAX || hours < INT32_MIN) { err_msg("hour_dateMinusDate: hours = %lld", (long long int)hours); err_msg("Exceeded the allowed range"); return (EC_RANGE); } *hours_ptr = hours; return (EC_OK); } /* hour_dateMinusDate */ static exit_t min_dateMinusDate(const yyyymmdd_t *const date1_ptr, const hhmmss_t *const hms1_ptr, const yyyymmdd_t *const date2_ptr, const hhmmss_t *const hms2_ptr, int32_t *const minutes_ptr) { int32_t julian1 = 0, julian2 = 0; int32_t second1 = 0, second2 = 0; int64_t minutes = 0; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date1_ptr, &julian1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = dateToJulian(date2_ptr, &julian2) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms1_ptr, &second1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms2_ptr, &second2) ) != EC_OK) { return (exit_status); } minutes = (julian1 - julian2) * (int64_t) MIN_DAY + (second1 - second2) / SEC_MIN ; if ( minutes > INT32_MAX || minutes < INT32_MIN) { err_msg("min_dateMinusDate: minutes = %lld", (long long int)minutes); err_msg("Exceeded the allowed range"); return (EC_RANGE); } *minutes_ptr = minutes; return (EC_OK); } /* min_dateMinusDate */ static exit_t sec_dateMinusDate(const yyyymmdd_t *const date1_ptr, const hhmmss_t *const hms1_ptr, const yyyymmdd_t *const date2_ptr, const hhmmss_t *const hms2_ptr, int32_t *const seconds_ptr) { int32_t julian1 = 0, julian2 = 0; int32_t second1 = 0, second2 = 0; int64_t seconds = 0; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date1_ptr, &julian1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = dateToJulian(date2_ptr, &julian2) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms1_ptr, &second1) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms2_ptr, &second2) ) != EC_OK) { return (exit_status); } seconds = (julian1 - julian2) * (int64_t) SEC_DAY + (second1 - second2); if ( seconds > INT32_MAX || seconds < INT32_MIN) { err_msg("sec_dateMinusDate: seconds = %lld", (long long int)seconds); err_msg("Exceeded the allowed range"); return (EC_RANGE); } *seconds_ptr = seconds; return (EC_OK); } /* sec_dateMinusDate */ static exit_t centuryToDate(const int32_t century, yyyymmdd_t *date_ptr) { int32_t julian = 0; exit_t exit_status = 0; julian = century + CENTURYSHIFT - 1; if ( ( exit_status = julianToDate(julian, date_ptr) ) != EC_OK) { return (exit_status); } return (EC_OK); } /* centuryToDate */ INLINE static exit_t dateToCentury(const yyyymmdd_t *const date_ptr, int32_t *const century_ptr) { int32_t century = 0; exit_t exit_status = 0; if ( is_date(date_ptr) != EC_OK ) { err_msg("Date incorrect (%04d%02d%02d)", (int)date_ptr->year, (int)date_ptr->month, (int)date_ptr->day); return (EC_DATEINV); } if ( ( exit_status = dateToJulian(date_ptr, ¢ury) ) != EC_OK) { return (exit_status); } *century_ptr = century - CENTURYSHIFT + 1; return (EC_OK); } /* dateToCentury */ static exit_t dateToYearday(const yyyymmdd_t *const date_ptr, int32_t *const yearday_ptr) { int32_t century = 0, year = 0; yyyymmdd_t year_date = {0,0,0}; exit_t exit_status = 0; if ( is_date(date_ptr) != EC_OK ) { err_msg("Date incorrect (%04d%02d%02d)", (int)date_ptr->year, (int)date_ptr->month, (int)date_ptr->day); return (EC_DATEINV); } if ( ( exit_status = dateToJulian(date_ptr, ¢ury) ) != EC_OK) { return (exit_status); } year_date.year = date_ptr->year; year_date.month = 1; year_date.day = 1; if ( ( exit_status = dateToJulian(&year_date, &year) ) != EC_OK) { return (exit_status); } *yearday_ptr = century - year + 1; return (EC_OK); } /* dateToYearday */ static exit_t yeardayToDate(const int32_t yearday, const int32_t year, yyyymmdd_t *date_ptr) { int32_t shift = 0, julian = 0; yyyymmdd_t year_date = {0,0,0}; exit_t exit_status = 0; year_date.year = year; year_date.month = 1; year_date.day = 1; if ( is_date(&year_date) != EC_OK ) { err_msg("Date incorrect (%04d%02d%02d)", (int)year_date.year, (int)year_date.month, (int)year_date.day); return (EC_DATEINV); } if ( ( exit_status = dateToJulian(&year_date, &shift) ) != EC_OK) { return (exit_status); } julian = yearday + shift - 1; if ( ( exit_status = julianToDate(julian, date_ptr) ) != EC_OK) { return (exit_status); } return (EC_OK); } /* yeardayToDate */ static exit_t addDays(const yyyymmdd_t *const date_ptr, const int32_t days, yyyymmdd_t *const new_date_ptr) { int64_t julian = 0; int32_t jul = 0; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date_ptr, &jul) ) != EC_OK) { return (exit_status); } julian = jul; julian += days; if ( julian > INT32_MAX || julian < INT32_MIN) { err_msg("addDays: julian = %lld", (long long int)julian); err_msg("Exceeded the allowed range"); return (EC_RANGE); } jul = (int32_t) julian; if ( ( exit_status = julianToDate(jul, new_date_ptr) ) != EC_OK) { return (exit_status); } return (EC_OK); } /* addDays */ static exit_t addHours(const yyyymmdd_t *const date_ptr, const hhmmss_t *const hms_ptr, const int32_t hours, yyyymmdd_t *const new_date_ptr, hhmmss_t *const new_hms_ptr) { mydate_t fulldate_str = {0,0}, new_fulldate_str = {0,0}; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date_ptr, &fulldate_str.julian) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms_ptr, &fulldate_str.seconds) ) != EC_OK) { return (exit_status); } if ( ( exit_status = _addHours(&fulldate_str, hours, &new_fulldate_str) ) != EC_OK) { return (exit_status); } if ( ( exit_status = julianToDate(new_fulldate_str.julian, new_date_ptr) ) != EC_OK) { return (exit_status); } if ( ( exit_status = secondsToHms(new_fulldate_str.seconds, new_hms_ptr) ) != EC_OK) { return (exit_status); } return (EC_OK); } /* addHours */ static exit_t addMinutes(const yyyymmdd_t *const date_ptr, const hhmmss_t *const hms_ptr, const int32_t minutes, yyyymmdd_t *const new_date_ptr, hhmmss_t *const new_hms_ptr) { mydate_t fulldate_str = {0,0}, new_fulldate_str = {0,0}; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date_ptr, &fulldate_str.julian) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms_ptr, &fulldate_str.seconds) ) != EC_OK) { return (exit_status); } if ( ( exit_status = _addMinutes(&fulldate_str, minutes, &new_fulldate_str) ) != EC_OK) { return (exit_status); } if ( ( exit_status = julianToDate(new_fulldate_str.julian, new_date_ptr) ) != EC_OK) { return (exit_status); } if ( ( exit_status = secondsToHms(new_fulldate_str.seconds, new_hms_ptr) ) != EC_OK) { return (exit_status); } return (EC_OK); } /* addMinutes */ static exit_t addSeconds(const yyyymmdd_t *const date_ptr, const hhmmss_t *const hms_ptr, const int32_t seconds, yyyymmdd_t *const new_date_ptr, hhmmss_t *const new_hms_ptr) { mydate_t fulldate_str = {0,0}, new_fulldate_str = {0,0}; exit_t exit_status = 0; if ( ( exit_status = dateToJulian(date_ptr, &fulldate_str.julian) ) != EC_OK) { return (exit_status); } if ( ( exit_status = hmsToSeconds(hms_ptr, &fulldate_str.seconds) ) != EC_OK) { return (exit_status); } if ( ( exit_status = _addSeconds(&fulldate_str, seconds, &new_fulldate_str) ) != EC_OK) { return (exit_status); } if ( ( exit_status = julianToDate(new_fulldate_str.julian, new_date_ptr) ) != EC_OK) { return (exit_status); } if ( ( exit_status = secondsToHms(new_fulldate_str.seconds, new_hms_ptr) ) != EC_OK) { return (exit_status); } return (EC_OK); } /* addSeconds */ static exit_t _addHours(const mydate_t *const fulldate_ptr, const int32_t hours, mydate_t *const new_fulldate_ptr) { int32_t days = 0; int32_t new_hours = 0; int32_t new_seconds = 0; new_hours = hours; days = new_hours / HOUR_DAY; new_fulldate_ptr->julian = fulldate_ptr->julian + days; new_hours %= HOUR_DAY; new_seconds = new_hours * SEC_HOUR; new_fulldate_ptr->seconds = fulldate_ptr->seconds + new_seconds; if ( new_fulldate_ptr->seconds < 0) { new_fulldate_ptr->julian --; new_fulldate_ptr->seconds = new_fulldate_ptr->seconds + SEC_DAY; } if ( new_fulldate_ptr->seconds >= SEC_DAY) { new_fulldate_ptr->julian ++; new_fulldate_ptr->seconds = new_fulldate_ptr->seconds - SEC_DAY; } return (EC_OK); } /* _addHours */ static exit_t _addMinutes(const mydate_t *const fulldate_ptr, const int32_t minutes, mydate_t *const new_fulldate_ptr) { int32_t days = 0; int32_t new_minutes = 0; int32_t new_seconds = 0; new_minutes = minutes; days = new_minutes / MIN_DAY; new_fulldate_ptr->julian = fulldate_ptr->julian + days; new_minutes %= MIN_DAY; new_seconds = new_minutes * SEC_MIN; new_fulldate_ptr->seconds = fulldate_ptr->seconds + new_seconds; if ( new_fulldate_ptr->seconds < 0) { new_fulldate_ptr->julian --; new_fulldate_ptr->seconds = new_fulldate_ptr->seconds + SEC_DAY; } if ( new_fulldate_ptr->seconds >= SEC_DAY) { new_fulldate_ptr->julian ++; new_fulldate_ptr->seconds = new_fulldate_ptr->seconds - SEC_DAY; } return (EC_OK); } /* _addMinutes */ static exit_t _addSeconds(const mydate_t *const fulldate_ptr, const int32_t seconds, mydate_t *const new_fulldate_ptr) { int32_t days = 0; int32_t new_seconds = 0; new_seconds = seconds; days = new_seconds / SEC_DAY; new_fulldate_ptr->julian = fulldate_ptr->julian + (int32_t) days; new_seconds %= SEC_DAY; new_fulldate_ptr->seconds = fulldate_ptr->seconds + (int32_t) new_seconds; if ( new_fulldate_ptr->seconds < 0) { new_fulldate_ptr->julian --; new_fulldate_ptr->seconds = new_fulldate_ptr->seconds + SEC_DAY; } else if ( new_fulldate_ptr->seconds >= SEC_DAY) { new_fulldate_ptr->julian ++; new_fulldate_ptr->seconds = new_fulldate_ptr->seconds - SEC_DAY; } return (EC_OK); } /* _addSeconds */ INLINE static exit_t hmsToSeconds(const hhmmss_t *const hms_ptr, int32_t *const seconds) { if ( is_hms(hms_ptr) != EC_OK ) { err_msg("Time incorrect (%02d%02d%02d)", (int)hms_ptr->hour, (int)hms_ptr->min, (int)hms_ptr->sec); return (EC_TIMEINV); } *seconds = SEC_HOUR * hms_ptr->hour + SEC_MIN * hms_ptr->min + hms_ptr->sec; return (EC_OK); } /* hmsToSeconds */ static exit_t secondsToHms(const int32_t seconds, hhmmss_t *const hms_ptr) { int32_t local_sec = 0; if ( seconds < 0 || seconds > SEC_DAY) return (EC_FALSE); local_sec = seconds; hms_ptr->hour = local_sec / SEC_HOUR; local_sec %= SEC_HOUR; hms_ptr->min = local_sec / MIN_HOUR; local_sec %= MIN_HOUR; hms_ptr->sec = local_sec; return (EC_OK); } /* secondsToHms */ static exit_t julianToDate(const int32_t julian, yyyymmdd_t *const date_ptr) { int64_t l = 0, n = 0, i = 0, j = 0; int64_t jdate = 0; int64_t day = 0; int64_t month = 0; int64_t year = 0; /* * Modified Julian date */ jdate = julian + MJDSHIFT; if ( jdate < JULIAN_MIN ) { err_msg("Julian = %lld", (long long int)jdate); err_msg("Julian less than %lld", (long long int)JULIAN_MIN); return (EC_FALSE); } /* l = julian_day + 68569 n = ( 4 * l ) / 146097 l = l - ( 146097 * n + 3 ) / 4 i = ( 4000 * ( l + 1 ) ) / 1461001 (that's 1,461,001) l = l - ( 1461 * i ) / 4 + 31 j = ( 80 * l ) / 2447 d = l - ( 2447 * j ) / 80 l = j / 11 m = j + 2 - ( 12 * l ) y = 100 * ( n - 49 ) + i + l */ l = jdate + 68569; n = ( 4 * l ) / 146097; l = l - ( 146097 * n + 3 ) / 4; i = ( 4000 * ( l + 1 ) ) / 1461001; l = l - ( 1461 * i ) / 4 + 31; j = ( 80 * l ) / 2447; day = l - ( 2447 * j ) / 80; l = j / 11; month = j + 2 - ( 12 * l ); year = 100 * ( n - 49 ) + i + l; if ( year > INT32_MAX || year < INT32_MIN) { err_msg("julianToDate: Year = %lld", (long long int)year); err_msg("Exceeded the allowed range"); return (EC_RANGE); } date_ptr->day = day; date_ptr->month = month; date_ptr->year = year; return (EC_OK); } /* julianToDate */ static exit_t dateToJulian(const yyyymmdd_t *const date_ptr, int32_t *const julian) { int32_t m1 = 0, m2 = 0, a = 0, b = 0, c = 0; /* int64_t jul = 0;*/ if ( is_date(date_ptr) != EC_OK ) { err_msg("Date incorrect (%04d%02d%02d)", (int)date_ptr->year, (int)date_ptr->month, (int)date_ptr->day); return (EC_DATEINV); } /* * Compute the Julian Day number applying the following formula julian_day = ( 1461 * ( y + 4800 + ( m - 14 ) / 12 ) ) / 4 + ( 367 * ( m - 2 - 12 * ( ( m - 14 ) / 12 ) ) ) / 12 - ( 3 * ( ( y + 4900 + ( m - 14 ) / 12 ) / 100 ) ) / 4 + d - 32075 */ m1 = (date_ptr->month - 14)/12; a = (1461 * (date_ptr->year + 4800 + m1))/4; b = (367 * (date_ptr->month - 2 - (12 * m1)))/12; m2 = (date_ptr->year + 4900 + m1)/100; c = (3 * (m2))/4; /* jul = a + b - c + date_ptr->day - 32075 - MJDSHIFT; if ( jul > LONG_MAX || jul < LONG_MIN) { err_msg("dateToJulian: Julian = %lld", jul); err_msg("Exceeded the allowed range"); return (EC_RANGE); } */ *julian = a + b - c + date_ptr->day - 32075 - MJDSHIFT; return (EC_OK); } /* dateToJulian */ static exit_t is_hms(const hhmmss_t *const hms_ptr) { if ( hms_ptr->hour < 0 || hms_ptr->hour > HOUR_DAY - 1 || hms_ptr->min < 0 || hms_ptr->min > MIN_HOUR - 1 || hms_ptr->sec < 0 || hms_ptr->sec > SEC_MIN - 1 ) return (EC_TIMEINV); else return (EC_OK); } /* is_hms */ static exit_t is_date(const yyyymmdd_t *const date_ptr) { if ( date_ptr->year < YEAR_MIN || date_ptr->year > YEAR_MAX) { err_msg("Year %d out of allowed range", (int)date_ptr->year); return(EC_RANGE); } if ( date_ptr->month < 1 || date_ptr->month > 12 || date_ptr->day < 1 || date_ptr->day > (date_ptr->month==2?(leap(date_ptr->year)?29:28):month_len[date_ptr->month - 1]) ) { return (EC_DATEINV); } else { return (EC_OK); } } /* is_date */ /* Nonfatal error unrelated to a system call. * Print a message and return. */ static void err_msg(const char *fmt, ...) { va_list ap; va_start(ap, fmt); char buf[ERR_MAXLINE]; (void) vsprintf(buf, fmt, ap); (void) strcat(buf, "\n"); (void) fflush(stdout); /* in case stdout and stderr are the same */ (void) fputs(buf, stderr); (void) fflush(stderr); /* SunOS 4.1.* doesn't grok NULL argument */ va_end(ap); return; } #ifdef __cplusplus } // extern "C" #endif #endif /* __julian_H__ */ fiat-ecmwf-2.0.0/src/fiat/util/internal/cptime.F900000664000175000017500000000275615157200431021773 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! !RJ: make interfaceable; generalization SUBROUTINE CPTIME(PVCP,PTCP) USE EC_PARKIND, ONLY : JPRD, JPIM IMPLICIT NONE REAL(KIND=JPRD) :: PVCP REAL(KIND=JPRD) :: PTCP ! #if defined (NEWTIMER) ! this routine should work better with OpenMP ! But doesn't work on Cray - and in any case does not return ! CPU time for all threads combined INTEGER(KIND=JPIM),SAVE :: IFIRST=1 INTEGER(KIND=JPIM),SAVE :: KFIRST,KTPS INTEGER(KIND=JPIM) :: KTICK ! Usage of Fortran95 intrinsic function system_clock for ELAPSED time, ! thus taking into account the parallelism if inside an open-mp region. REK IF(IFIRST.EQ.1) THEN IFIRST=0 CALL SYSTEM_CLOCK(KFIRST,KTPS) PVCP=0.0_JPRD PTCP=PVCP ELSE CALL SYSTEM_CLOCK(KTICK) PVCP=REAL(KTICK-KFIRST,KIND=JPRD)/REAL(KTPS,KIND=JPRD) PTCP=PVCP ENDIF #else INTEGER(KIND=JPIM),SAVE :: IFIRST=0 REAL(KIND=JPRD),SAVE :: ZFIRST REAL(KIND=JPRD) :: ZSEC ! Usage of Fortran95 intrinsic function for CPU timing. IF(IFIRST.EQ.0) THEN IFIRST=1 CALL CPU_TIME(ZFIRST) PVCP=0.0_JPRD PTCP=PVCP ELSE CALL CPU_TIME(ZSEC) PVCP=ZSEC-ZFIRST PTCP=PVCP ENDIF #endif ! RETURN END SUBROUTINE CPTIME fiat-ecmwf-2.0.0/src/fiat/util/internal/get_openmp.F900000664000175000017500000000110615157200431022633 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! subroutine get_openmp(kopenmp) use EC_PARKIND, only : JPIM implicit none INTEGER(KIND=JPIM), INTENT(out) :: kopenmp #ifdef _OPENMP kopenmp = _OPENMP #else kopenmp = 0 #endif end subroutine get_openmp fiat-ecmwf-2.0.0/src/fiat/util/ec_flush.F900000664000175000017500000000125515157200431020457 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE EC_FLUSH(UNIT) !USE, INTRINSIC :: iso_fortran_env, ONLY: FLUSH USE EC_PARKIND, ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: UNIT INTEGER(KIND=JPIM) :: IERR IF (UNIT >= 0) THEN FLUSH(UNIT,IOSTAT=IERR,ERR=99) ! F2003 or later ENDIF 99 CONTINUE END SUBROUTINE EC_FLUSH fiat-ecmwf-2.0.0/src/fiat/util/bytes_io.c0000664000175000017500000005341715157200431020377 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /** This file describes a number of subroutines which can be called from FORTRAN to handle an unblocked binary file: BYTES_IO_OPEN to open the file BYTES_IO_CLOSE to close the file BYTES_IO_TELL to give position in the file (optional) BYTES_IO_SEEK to position the file (optional) BYTES_IO_READ to read from the file BYTES_IO_WRITE to write to the file BYTES_IO_FLUSH to flush the file The subroutines are written in C and use standard library functions for file handling (fopen, fclose, fseek, ftell, fread and fwrite). These routines are a direct replacement for: - PBOPEN - PBCLOSE - PBTELL - PBSEEK - PBREAD - PBWRITE - PBFLUSH BYTES_IO_OPEN ============= A subroutine which can be called from FORTRAN to open an unblocked binary file and return a suitable unit number for use in calls to BYTES_IO_READ, and BYTES_IO_WRITE, BYTES_IO_SEEK, BYTES_IO_TELL. The format and arguments for the subroutine are as follows: SUBROUTINE BYTES_IO_OPEN(KUNIT,FILENAME,MODE,KRET) where: Input parameters are CHARACTERs: -------------------------------- FILENAME = a character string describing the file MODE = a character string describing the mode of access to the file: r for read w for write a for append Output parameters are INTEGERs: ------------------------------- KUNIT = unit number for the file - it is a C FILE pointer and not a FORTRAN unit number. KRET = -1 = Could not open file. -2 = Invalid file name. -3 = Invalid open mode specified 0 = OK. BYTES_IO_CLOSE ============== A subroutine which can be called from FORTRAN to close an unblocked binary file previously opened with BYTES_IO_OPEN. The format and arguments for the subroutine are as follows: SUBROUTINE BYTES_IO_CLOSE(KUNIT,KRET) where: Input parameter is an INTEGER: ------------------------------ KUNIT = unit number for the file; this must have been obtained by calling BYTES_IO_OPEN (see below) - it is a C FILE pointer and not a FORTRAN unit number. Output parameter is an INTEGER: ------------------------------- KRET = -1 error in handling the file. 0 = OK. BYTES_IO_SEEK ============= A subroutine which can be called from FORTRAN to position an unblocked binary file at any desired byte position. The format and arguments for the subroutine are as follows: SUBROUTINE BYTES_IO_SEEK(KUNIT,KOFFSET,KSTART,KRET) where: Input parameters are INTEGERs: ------------------------------ KUNIT = unit number for the file; this must have been obtained by calling BYTES_IO_OPEN (see below) - it is a C FILE pointer and not a FORTRAN unit number. KOFFSET = number of bytes to offset the file; this is used as either an absolute or relative offset depending on the value of KSTART. KSTART = 0 if KOFFSET is an absolute count from the beginning of the file, 1 if KOFFSET is a relative offset from the current byte position in the file, 2 if KOFFSET is an absolute offset from the end of file. Output parameter is an INTEGER: ------------------------------- KRET = -2 if there is an error in handling the file -1 if end-of-file is encountered (Note that EOF does not cause a program fail, so this value must be explicitly caught by the caller to avoid looping at the EOF) >= 0 byte offset from the start of file after positioning. BYTES_IO_READ ============= A subroutine which can be called from FORTRAN to read a block of bytes from an unblocked binary file. ( Note that this routine behaves differently from BYTES_IO_READ2 on hitting end-of-file. ) The format and arguments for the subroutine are as follows: SUBROUTINE BYTES_IO_READ(KUNIT,KARRAY,KOUNT,KRET) where: Input parameters are INTEGERs: ------------------------------ KUNIT = unit number for the file; this must have been obtained by calling BYTES_IO_OPEN (see below) - it is a C FILE pointer and not a FORTRAN unit number. KOUNT = number of BYTES to read from the file. Output parameters are INTEGERs: ------------------------------ KARRAY = an INTEGER array to accept the bytes from the read. KRET = -2 if there is an error in handling the file -1 if end-of-file is encountered (Note that EOF does not cause a program fail, so this value must be explicitly caught by the caller to avoid looping at the EOF) >= 0 number of BYTES read from the file. BYTES_IO_WRITE ============== A subroutine which can be called from FORTRAN to write a block of bytes to an unblocked binary file. The format and arguments for the subroutine are as follows: SUBROUTINE BYTES_IO_WRITE(KUNIT,KARRAY,KOUNT,KRET) where: Input parameters are INTEGERs: ------------------------------ KUNIT = unit number for the file; this must have been obtained by calling BYTES_IO_OPEN (see below) - it is a C FILE pointer and not a FORTRAN unit number. KARRAY = an INTEGER array holding the bytes for the write. KOUNT = number of BYTES to write to the file. Output parameter is an INTEGER: ------------------------------- KRET = -1 if there is an error in writing to the file >= 0 number of BYTES written to the file. */ /* // bytes_io.c */ #include #include #include #include #include #include #include #include #include #ifdef PTHREADS #include #endif static FILE** fptable = NULL; static int fptableSize = 0; #ifdef PTHREADS static pthread_mutex_t fpTableBusy = PTHREAD_MUTEX_INITIALIZER; #endif #define BUFFLEN 4096 /* // Default buffer size for I/O operations (set via setvbuf) */ #define SIZE BUFSIZ static long size = SIZE; static int sizeSet = 0; static char * envSize; static char** fileBuffer = NULL; /* // Debug flags. */ #define DEBUGOFF 1 #define DEBUG (debugSet > DEBUGOFF ) static char * debugLevel; static int debugSet = 0; #define NAMEBUFFLEN 256 #define MODEBUFFLEN 10 #define CURRENT_FILE (fptable[*unit]) /* //------------------------------------------------------------------------ // BYTES_IO_OPEN - Open file (from FORTRAN) //------------------------------------------------------------------------ */ void c_bytes_io_open_( int* unit, char* name, char* mode, int* iret, int l1, int l2 ) { /* // Purpose: // Opens file, returns the index of a UNIX FILE pointer held in // an internal table (fptable). // // First time through, reads value in environment variable BYTES_IO_BUFSIZE // (if it is set) and uses it as the size to be used for internal file // buffers; the value is passed to setvbuf. If BYTES_IO_BUFSIZE is not set, // a default value is used. // // Function accepts: // name = filename // mode = r, r+, w // // Note: l1 and l2 are the lengths of the FORTRAN character strings // in name and mode, and should not be passed. // // Function returns: // INTEGER iret: // -1 = Could not open file. // -2 = Invalid file name. // -3 = Invalid open mode specified // 0 = OK. */ int n; char *p; char flags[4]; char namebuff[NAMEBUFFLEN+1], modebuff[MODEBUFFLEN+1]; /* // See if DEBUG switched on. */ if( ! debugSet ) { debugLevel = getenv("BYTES_IO_DEBUG"); if( debugLevel == NULL ) debugSet = DEBUGOFF; /* off */ else { size_t loop; for( loop = 0; loop < strlen(debugLevel) ; loop++ ) { if( ! isdigit(debugLevel[loop]) ) { printf("Invalid number string in BYTES_IO_DEBUG: %s\n", debugLevel); printf("BYTES_IO_DEBUG must comprise only digits [0-9].\n"); debugSet = DEBUGOFF; } } debugSet = DEBUGOFF + atol( debugLevel ); } if( DEBUG ) printf("BYTES_IO_OPEN: debug switched on\n"); } /* // Put the character strings into buffers and ensure that there is a // null terminator (for SGI case when FORTRAN CHARACTER variable is full // right to end with characters */ { int n1, n2; n1 = (l1>NAMEBUFFLEN) ? NAMEBUFFLEN : l1; n2 = (l2>MODEBUFFLEN) ? MODEBUFFLEN : l2; strncpy( namebuff, name, n1); strncpy( modebuff, mode, n2); namebuff[n1] = '\0'; modebuff[n2] = '\0'; } strcpy(flags,""); /* *unit = (int) NULL; sami bug fix */ *unit = 0; *iret = 0; /* // Strip trailing blanks */ p = namebuff + strlen(namebuff) - 1 ; while(*p == ' ') { *p = 0; p--; } if( DEBUG ) printf("BYTES_IO_OPEN: filename = [%s]\n", namebuff); /* // Build open flags from "modes" */ p = modebuff; switch(*p) { case 'a': case 'A': strcat(flags, "a"); break; case 'c': case 'C': case 'w': case 'W': strcat(flags, "w"); break; case 'r': case 'R': if( *(p+1) == '+' ) strcat(flags, "r+"); else strcat(flags, "r"); break; default: *iret = -3; return; } if( DEBUG ) printf("BYTES_IO_OPEN: file open mode = %s\n", flags); /* // Look for a free slot in fptable. // (Create the table the first time through). */ #ifdef PTHREADS /* // Wait if another thread opening a file */ pthread_mutex_lock(&fpTableBusy); #endif n = 0; if( fptableSize == 0 ) { int i; fptableSize = 2; fptable = (FILE **) malloc(fptableSize*sizeof(FILE *)); if( fptable == NULL ) { perror("Unable to allocate space for table of FILE pointers"); exit(1); } fileBuffer = (char **) malloc(fptableSize*sizeof(char *)); if( fileBuffer == NULL ) { perror("Unable to allocate space for FILE buffers"); exit(1); } for( i = 0; i < fptableSize; i++ ) { fptable[i] = 0; fileBuffer[i] = NULL; } } else { while( n < fptableSize ) { if(fptable[n]==0) { *unit = n; break; } n++; } } /* // If the table overflows, double its size. */ if( n == fptableSize) { int i; fptableSize = 2*fptableSize; fptable = (FILE **) realloc(fptable, fptableSize*sizeof(FILE *)); if( fptable == NULL ) { perror("Unable to reallocate space for table of FILE pointers"); exit(1); } n = fptableSize/2; fileBuffer = (char **) realloc(fileBuffer, fptableSize*sizeof(char *)); if( fileBuffer == NULL ) { perror("Unable to allocate space for FILE buffers"); exit(1); } n = fptableSize/2; for( i = n; i < fptableSize; i++ ) { fptable[i] = 0; fileBuffer[i] = NULL; } *unit = n; } if( DEBUG ) printf("BYTES_IO_OPEN: fptable slot = %d\n", *unit); if( DEBUG ) printf("BYTES_IO_OPEN: using fopen\n"); fptable[n] = fopen(namebuff, flags ); if(fptable[n] == NULL) { perror(namebuff); *iret = -1; #ifdef PTHREADS pthread_mutex_unlock(&fpTableBusy); #endif return; } /* // Now allocate a buffer for the file, if necessary. */ if( ! sizeSet ) { envSize = getenv("BYTES_IO_BUFSIZE"); if( envSize == NULL ) size = SIZE; /* default */ else { size_t loop; for( loop = 0; loop < strlen(envSize) ; loop++ ) { if( ! isdigit(envSize[loop]) ) { printf("Invalid number string in BYTES_IO_BUFSIZE: %s\n", envSize); printf("BYTES_IO_BUFSIZE must comprise only digits [0-9].\n"); exit(1); } } size = atol( envSize ); } if( size <= 0 ) { printf("Invalid buffer size in BYTES_IO_BUFSIZE: %s\n", envSize); printf("Buffer size defined by BYTES_IO_BUFSIZE must be positive.\n"); exit(1); } sizeSet = 1; } if( DEBUG ) printf("BYTES_IO_OPEN: file buffer size = %ld\n", size); if( fileBuffer[n] == NULL ) { fileBuffer[n] = (char *) malloc(size); } if( setvbuf(CURRENT_FILE, fileBuffer[*unit], _IOFBF, size) ) { perror("setvbuf failed"); *iret = -1; } #ifdef PTHREADS pthread_mutex_unlock(&fpTableBusy); #endif } void c_bytes_io_open__( int* unit, char* name, char* mode, int* iret, int l1, int l2 ) { c_bytes_io_open_(unit,name,mode,iret,l1,l2); } void c_bytes_io_open( int* unit, char* name, char* mode, int* iret, int l1, int l2 ) { c_bytes_io_open_(unit,name,mode,iret,l1,l2); } /* //------------------------------------------------------------------------ // BYTES_IO_SEEK - Seek (from FORTRAN) //------------------------------------------------------------------------ */ void c_bytes_io_seek_(int* unit,int* offset,int* whence,int* iret) { /* // // Purpose: // Seeks to a specified location in file. // // Function accepts: // unit = the index of a UNIX FILE pointer held in // an internal table (fptable). // // offset = byte count // // whence = 0, from start of file // = 1, from current position // = 2, from end of file. // // Returns: // iret: // -2 = error in handling file, // -1 = end-of-file // otherwise, = byte offset from start of file. */ int my_offset = (int) *offset; int my_whence = (int) *whence; /* // Must use negative offset if working from end-of-file */ if( DEBUG ) { printf("BYTES_IO_SEEK: fptable slot = %d\n", *unit); printf("BYTES_IO_SEEK: Offset = %d\n", my_offset); printf("BYTES_IO_SEEK: Type of offset = %d\n", my_whence); } if( my_whence == 2) my_offset = - abs(my_offset); *iret = ftell(CURRENT_FILE); if( DEBUG ) printf("BYTES_IO_SEEK: current position = %d\n", *iret); if( *iret == my_offset && my_whence == 0) *iret = 0; else *iret = fseek(CURRENT_FILE, my_offset, my_whence); if( DEBUG ) printf("BYTES_IO_SEEK: fseek return code = %d\n",*iret); if( *iret != 0 ) { if( ! feof(CURRENT_FILE) ) { *iret = -2; /* error in file-handling */ perror("bytes_io_seek"); } else *iret = -1; /* end-of-file */ clearerr(CURRENT_FILE); return; } /* // Return the byte offset from start of file */ *iret = ftell(CURRENT_FILE); if( DEBUG ) printf("BYTES_IO_SEEK: byte offset from start of file = %d\n",*iret); return; } void c_bytes_io_seek(int* unit,int* offset,int* whence,int* iret) { c_bytes_io_seek_(unit,offset,whence,iret); } /* //------------------------------------------------------------------------ // BYTES_IO_TELL - Tells current file position (from FORTRAN) //------------------------------------------------------------------------ */ void c_bytes_io_tell_(int* unit,int* iret) { /* // // Purpose: // Tells current byte offset in file. // // Function accepts: // unit = the index of a UNIX FILE pointer held in // an internal table (fptable). // // Returns: // iret: // -2 = error in handling file, // otherwise, = byte offset from start of file. */ /* // Return the byte offset from start of file */ *iret = ftell(CURRENT_FILE); if( *iret < 0 ) { if( DEBUG ) { /* error in file-handling */ printf("BYTES_IO_TELL: fptable slot = %d. ", *unit); printf("Error status = %d\n", *iret); } perror("bytes_io_tell"); *iret = -2; } if( DEBUG ) { printf("BYTES_IO_TELL: fptable slot = %d. ", *unit); printf("Byte offset from start of file = %d\n",*iret); } return; } void c_bytes_io_tell__(int* unit,int* iret) { c_bytes_io_tell_(unit,iret); } void c_bytes_io_tell(int* unit,int* iret) { c_bytes_io_tell_(unit,iret); } /* //------------------------------------------------------------------------ // BYTES_IO_READ - Read (from FORTRAN) //------------------------------------------------------------------------ */ void c_bytes_io_read_(int* unit,char* buffer,int* nbytes,int* iret) { /* // Purpose: // Reads a block of bytes from a file.. // // Function accepts: // unit = the index of a UNIX FILE pointer held in // an internal table (fptable). // // nbytes = number of bytes to read. // // Returns: // iret: // -2 = error in reading file, // -1 = end-of-file, // otherwise, = number of bytes read. */ if( DEBUG ) { printf("BYTES_IO_READ: fptable slot = %d. ", *unit); printf("Number of bytes to read = %d\n", *nbytes); } if( (*iret = fread(buffer, 1, *nbytes, CURRENT_FILE) ) != *nbytes) { if( ! feof(CURRENT_FILE) ) { *iret = -2; /* error in file-handling */ perror("bytes_io_read"); clearerr(CURRENT_FILE); return; } else { *iret = -1; /* end-of-file */ clearerr(CURRENT_FILE); } } if( DEBUG ) { printf("BYTES_IO_READ: fptable slot = %d. ", *unit); printf("Number of bytes read = %d\n", *nbytes); } return; } void c_bytes_io_read__(int* unit,char* buffer,int* nbytes,int* iret) { c_bytes_io_read_(unit,buffer,nbytes,iret); } void c_bytes_io_read(int* unit,char* buffer,int* nbytes,int* iret) { c_bytes_io_read_(unit,buffer,nbytes,iret); } /* //------------------------------------------------------------------------ // BYTES_IO_WRITE - Write (from FORTRAN) //------------------------------------------------------------------------ */ void c_bytes_io_write_(int* unit,char* buffer,int* nbytes,int* iret) { /* // Purpose: // Writes a block of bytes to a file. // // Function accepts: // unit = the index of a UNIX FILE pointer held in // an internal table (fptable). // // nbytes = number of bytes to write. // // Returns: // iret: // -1 = Could not write to file. // >=0 = Number of bytes written. */ if( DEBUG ) { printf("BYTES_IO_WRITE: fptable slot = %d. ", *unit); printf("Number of bytes to write = %d\n", *nbytes); } if( (*iret = fwrite(buffer, 1, *nbytes, CURRENT_FILE) ) != *nbytes) { perror("bytes_io_write"); *iret = -1; } if( DEBUG ) { printf("BYTES_IO_WRITE: fptable slot = %d. ", *unit); printf("BYTES_IO_WRITE: number of bytes written = %d\n", *iret); } return; } void c_bytes_io_write__(int* unit,char* buffer,int* nbytes,int* iret) { c_bytes_io_write_(unit,buffer,nbytes,iret); } void c_bytes_io_write(int* unit,char* buffer,int* nbytes,int* iret) { c_bytes_io_write_(unit,buffer,nbytes,iret); } /* //------------------------------------------------------------------------ // BYTES_IO_FSYNC - fsync //------------------------------------------------------------------------ */ void c_bytes_io_fsync(int fd, int* iret) { // Same implementation of see eckit::fsync *iret = fsync(fd); while (*iret < 0 && errno == EINTR) { *iret = fsync(fd); } return; } /* //------------------------------------------------------------------------ // BYTES_IO_FLUSH - flush + fsync //------------------------------------------------------------------------ */ void c_bytes_io_flush_(int* unit, int* iret) { /* // Purpose: Flushes file. */ if( DEBUG ) printf("BYTES_IO_FLUSH: fptable slot = %d\n", *unit); // Implementation matching eckit FileHandle // flush if( (*iret = fflush(CURRENT_FILE)) != 0) { perror("bytes_io_flush: fflush failed"); return; } // fsync c_bytes_io_fsync(fileno(CURRENT_FILE),iret); while (*iret < 0 && errno == EINTR) { c_bytes_io_fsync(fileno(CURRENT_FILE),iret); } if (*iret < 0) { perror("bytes_io_flush: Cannot fsync"); return; } *iret = 0; return; } void c_bytes_io_flush__(int* unit, int* iret) { c_bytes_io_flush_(unit,iret); } void c_bytes_io_flush(int* unit, int* iret) { c_bytes_io_flush_(unit,iret); } /* //------------------------------------------------------------------------ // BYTES_IO_CLOSE - close (from FORTRAN) //------------------------------------------------------------------------ */ void c_bytes_io_close_(int* unit,int* iret) { /* // Purpose: // Closes file. // // Function accepts: // unit = the index of a UNIX FILE pointer held in // an internal table (fptable). //// Returns: // iret: // 0 = OK. // otherwise = error in handling file. */ *iret = 0; if( DEBUG ) { printf("BYTES_IO_CLOSE: fptable slot = %d\n", *unit); } if( !CURRENT_FILE ) { printf("WARNING: bytes_io_close: File (fptable slot = %d) was already closed.\n", *unit); return; } // Flush before closing c_bytes_io_flush(unit,iret); if( *iret != 0 ) { perror("bytes_io_close: could not flush"); return; } // Close if( ( *iret = fclose(CURRENT_FILE) ) != 0 ) { perror("bytes_io_close"); return; } CURRENT_FILE = 0; return; } void c_bytes_io_close__(int* unit,int* iret) { c_bytes_io_close_(unit,iret); } void c_bytes_io_close(int* unit,int* iret) { c_bytes_io_close_(unit,iret); } fiat-ecmwf-2.0.0/src/fiat/util/ec_args.c0000664000175000017500000001726615157200431020167 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #include #include #include #include #if defined(LINUX) #include #endif #ifdef __APPLE__ #include #include #endif #include "ec_args.h" #define EC_MAX_ARGS 512 typedef struct { char *name; int len; } arg_t; static arg_t *args = NULL; static const char* * c_argv = NULL; static int numargs = -1; static char *cl_terminate = NULL; static char *a_out = NULL; #if !defined(PSCMD) #define PSCMD "/bin/ps" #endif /* !defined(PSCMD) */ #if !defined(TAILCMD) #define TAILCMD "/usr/bin/tail" #endif /* !defined(TAILCMD) */ static const char *get_a_out() { /* progname is a blank string; this is most likely due to a Fortran-call to getarg from program that has a C-main program, thus Fortran getarg may return a blank string */ /* Using an alternative method of getting a.out : ps -p | tail -1 | awk '{print $NF}' This can give false positives, as we search the path for the binary: we may have executed ./MASTER rather than the first MASTER in the path. Naturally this cannot be the nicest method around ;-( So, a competition is launched: make this better and you may win a week in Bahamas!! */ #if defined(LINUX) /* On Linux, the following is more reliable, if /proc is available. */ if (!a_out) { int len; char symlink[NAME_MAX], real_exe[NAME_MAX]; snprintf(symlink, NAME_MAX, "/proc/%d/exe", getpid()); if ((len = readlink(symlink, real_exe, NAME_MAX)) > 0) { a_out = malloc((len+1)*sizeof(*a_out)); strncpy(a_out, real_exe, len); a_out[len] = '\0'; } } #elif defined(__APPLE__) /* On macOS, the following is more reliable */ if (!a_out) { char path[PROC_PIDPATHINFO_MAXSIZE]; pid_t pid = getpid(); int ret = proc_pidpath( pid, path, sizeof(path)); // For name only, use 'proc_name' instead if ( ret <= 0 ) { fprintf(stderr, "PID %d: proc_pidpath ();\n", pid); fprintf(stderr, " %s\n", strerror(errno)); } else { a_out = strdup(path); } } #endif if (!a_out && (access(PSCMD,X_OK) == 0)) { char cmd[sizeof(PSCMD) + sizeof(TAILCMD) + 100]; FILE *fp = NULL; pid_t pid = getpid(); sprintf(cmd,"%s -p%d | %s -1 | awk '{if (NF>4) {print $4} else {print $NF}}'", PSCMD, (int)pid, TAILCMD); fp = popen(cmd, "r"); if (fp) { char c[65536]; if (fscanf(fp,"%s",c) == 1) { if (!strchr(c,'/')) { /* The file path was NOT embedded in the name ==> Must search from $PATH f.ex. /bin:/usr/bin:/some/thing/else:/etc/bin */ char *path = getenv("PATH"); if (path) { int lenc = strlen(c); char *saved = strdup(path); char *start = saved; char *token = strtok(saved,":"); do { int lenf = strlen(start) + 1 + lenc + 1; char *fullpath = malloc(lenf * sizeof(*fullpath)); snprintf(fullpath,lenf,"%s/%s",start,c); if (access(fullpath,X_OK) == 0) { /* It's this one!! */ a_out = fullpath; break; /* do { ... } while (token) */ } free(fullpath); start = token; token = strtok(NULL,":"); } while (token); free(saved); } } /* if (!strchr(c,'/')) */ if (!a_out) a_out = strdup(c); } pclose(fp); } } if (!a_out) a_out = strdup("/unknown/executable"); return a_out; } static void reset_argv() { int i; if( c_argv == NULL ) { c_argv = calloc(EC_MAX_ARGS, sizeof(char*)); } for( i=0; i 0) { int j; args = calloc(argc, sizeof(arg_t)); reset_argv(); /* cl_terminate: see ifsaux/module/mpl_arg_mod.F90 */ if (!cl_terminate) { char *env = getenv("MPL_CL_TERMINATE"); cl_terminate = env ? strdup(env) : strdup("-^"); } numargs = 0; for (j=0; j 0) */ } /* if (numargs == -1 && !args) */ } /* * Return number of arguments + program name, as in C */ int ec_argc(void) { return 1 + numargs; } // Return array of 0-terminated arguments as in C const char* const* ec_argv(void) { if( c_argv == NULL ) { reset_argv(); // not thread safe c_argv[0] = a_out ? a_out : get_a_out(); } return c_argv; } /* * Legacy Fortran functions, currently only used within mpl_arg_mod * Please do not use! Use "ec_args_mod" instead */ int iargc_c_(void) { return numargs; } void getarg_c_(const int *argno, char *arg /* Hidden argument */ , const int arg_len) { int Argno = argno ? *argno : -1; int len = 0; const char *s = NULL; /* Special case : Argno := 0 i.e. the executable name */ if (arg && arg_len > 0 && Argno == 0) { if( a_out ) { s = a_out; } else { s = get_a_out(); } len = strlen(s); } else if ( arg && arg_len > 0 && Argno > 0 && Argno <= numargs && args && args[Argno].name) { s = args[Argno].name; len = args[Argno].len; } if (arg && arg_len > 0) memset(arg,' ',arg_len); if (s && len > 0) { if (arg_len < len) len = arg_len; strncpy(arg,s,len); if (arg_len > len) memset(&arg[len],' ',arg_len-len); } } void putarg_c_(const int *argno, const char *arg /* Hidden argument */ , int arg_len) { int Argno = argno ? *argno : -1; if (arg && arg_len >= 0 && Argno >= 0 && Argno <= numargs && args) { char *s = calloc(arg_len+1,sizeof(*s)); strncpy(s,arg,arg_len); s[arg_len] = '\0'; if (args[Argno].name) free(args[Argno].name); args[Argno].name = s; args[Argno].len = arg_len; c_argv[Argno] = args[Argno].name; } } void putarg_info_(const int *argc, const char *cterm /* Hidden argument */ , int cterm_len) { int Argc = argc ? *argc : 0; if (cterm && cterm_len >= 0) { if (cl_terminate) free(cl_terminate); cl_terminate = calloc(cterm_len+1,sizeof(*cl_terminate)); strncpy(cl_terminate,cterm,cterm_len); cl_terminate[cterm_len] = '\0'; } if (numargs >= 0 || args) { if (args) { int j; for (j=0; j<=numargs; j++) { /* note: "j<=", not "j<" */ if (args[j].name) { free(args[j].name); } } free(args); args = NULL; } /* if (args) */ numargs = -1; } /* Re-initialize args & numargs */ if (Argc < 0) Argc = 0; numargs = Argc; args = calloc(1 + numargs, sizeof(arg_t)); reset_argv(); } fiat-ecmwf-2.0.0/src/fiat/util/ec_checksum.c0000664000175000017500000000355415157200431021030 0ustar alastairalastair/* * (C) Copyright 2025- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include "ec_checksum.h" #include #include #include #include typedef union { ec_checksum_fletcher16_t checksum; uint16_t c[2]; } Fletcher16; static void fletcher_reset(Fletcher16* f) { f->c[0] = 0; f->c[1] = 0; } static void fletcher_update(Fletcher16* f, const uint8_t* data, size_t size) { uint32_t c0 = f->c[0]; uint32_t c1 = f->c[1]; while(size > 0) { size_t blocklen = size; if (blocklen > 5802) { blocklen = 5802; } size -= blocklen; do { c0 = c0 + *data++; c1 = c1 + c0; } while (--blocklen); c0 = c0 % 0xff; c1 = c1 % 0xff; } f->c[0] = c0; f->c[1] = c1; } static uint16_t fletcher_finish(const Fletcher16* f) { uint32_t c0 = f->c[0]; uint32_t c1 = f->c[1]; return (c1 << 8 | c0); } void ec_checksum_fletcher16_reset(ec_checksum_fletcher16_t* checksum) { fletcher_reset((Fletcher16*)checksum); } void ec_checksum_fletcher16_update(ec_checksum_fletcher16_t* checksum, const void* data, size_t bytes) { fletcher_update((Fletcher16*)checksum, (const uint8_t*)data, bytes); } uint16_t ec_checksum_fletcher16_digest(const ec_checksum_fletcher16_t* checksum) { return fletcher_finish((Fletcher16*)checksum); } uint16_t ec_checksum_fletcher16(const void* data, size_t bytes) { ec_checksum_fletcher16_t checksum; ec_checksum_fletcher16_reset(&checksum); ec_checksum_fletcher16_update(&checksum,data,bytes); return ec_checksum_fletcher16_digest(&checksum); } fiat-ecmwf-2.0.0/src/fiat/util/ec_endian.c0000664000175000017500000000253315157200431020460 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* endian.c */ /* Please note: the following 2 routines cannot be named as "is_little_endian()" and "is_big_endian()", since there is a clash with the new Magics++ library (by SS, 21-Mar-2006) --> consequently "ec_" prefix was added */ #include #include #include #include #include #include int ec_is_little_endian() { /* Little/big-endian runtime auto-detection */ const unsigned int ulbtest = 0x12345678; const unsigned char *clbtest = (const unsigned char *)&ulbtest; if (*clbtest == 0x78) { /* We are on a little-endian machine */ return 1; } else { /* We are on a big-endian machine */ return 0; } } int ec_is_big_endian() { return !ec_is_little_endian(); } /* Fortran interface */ int ec_is_big_endian_() { return ec_is_big_endian(); } int ec_is_little_endian_() { return ec_is_little_endian(); } fiat-ecmwf-2.0.0/src/fiat/util/ec_khz.F900000664000175000017500000000204715157200431020132 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE EC_KHZ(KOREID,KHZ) USE EC_PARKIND, ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KOREID INTEGER(KIND=JPIM),INTENT(OUT) :: KHZ INTEGER(KIND=JPIM) :: ITHISCORE, ISTAT INTEGER, external :: EC_COREID ! from ec_env.c ! /sys/devices/system/cpu/cpu0/cpufreq/scaling_cur_freq CHARACTER(LEN=80) :: CLSYS IF (KOREID >= 0) THEN ITHISCORE = KOREID ELSE ITHISCORE = EC_COREID() ENDIF WRITE(CLSYS,'(A,I0,A)') '/sys/devices/system/cpu/cpu',ITHISCORE,'/cpufreq/scaling_cur_freq' OPEN(505,FILE=trim(CLSYS),IOSTAT=ISTAT,STATUS='old',ACTION='read') IF (ISTAT == 0) THEN READ(505,*,IOSTAT=ISTAT) KHZ CLOSE(505) ENDIF IF (ISTAT /= 0) KHZ = 0 END SUBROUTINE EC_KHZ fiat-ecmwf-2.0.0/src/fiat/util/ec_env_mod.F900000664000175000017500000001120515157200431020761 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! module ec_env_mod !**** Interface to ec_env environment handling ! ! Purpose. ! -------- ! Fortran 90 Interface to setting and getting environment variables ! ! Author. ! ------- ! W.Deconinck, ECMWF ! ! Modifications. ! -------------- ! Original: 2021-05-18 ! ! ------------------------------------------------------------------ implicit none private public :: ec_putenv, ec_getenv, ec_setenv, ec_numenv, ec_environ interface !! ISO-C bindings from file ec_env.c subroutine ec_putenv_overwrite_bind_c(env,env_len) bind(C) use, intrinsic :: iso_c_binding, only : c_int, c_char character(kind=c_char), intent(in) :: env(*) integer(kind=c_int), value, intent(in) :: env_len end subroutine subroutine ec_putenv_nooverwrite_bind_c(env,env_len) bind(C) use, intrinsic :: iso_c_binding, only : c_int, c_char character(kind=c_char), intent(in) :: env(*) integer(kind=c_int), value, intent(in) :: env_len end subroutine subroutine ec_getenv_bind_c(key,value,key_len,value_len) bind(C) use, intrinsic :: iso_c_binding, only : c_int, c_char character(kind=c_char), intent(in) :: key(*) character(kind=c_char), intent(inout) :: value(*) integer(kind=c_int), value, intent(in) :: key_len integer(kind=c_int), value, intent(in) :: value_len end subroutine subroutine ec_numenv_bind_c(value) bind(C) use, intrinsic :: iso_c_binding, only : c_int integer(kind=c_int), intent(out) :: value end subroutine subroutine ec_environ_bind_c(i,value,value_len) bind(C) use, intrinsic :: iso_c_binding, only : c_int, c_char integer(kind=c_int), intent(in) :: i character(kind=c_char), intent(inout) :: value(*) integer(kind=c_int), value, intent(in) :: value_len end subroutine end interface contains subroutine ec_putenv(env, overwrite) !! Set environment. Add optional argument 'OVERWRITE=.false.' to avoid overwriting if already set. !! Example: !! call ec_putenv("DR_HOOK=1") ! Forces overwrite (default: OVERWRITE=.TRUE.) !! call ec_putenv("DR_HOOK=0",OVERWRITE=.FALSE) ! Will have no effect as DR_HOOK=1 already exists !! character(len=*), intent(in) :: env logical, optional, intent(in) :: overwrite ! assume true if not present if( present(overwrite) ) then if( overwrite ) then call ec_putenv_overwrite_bind_c(env,len(env)) else call ec_putenv_nooverwrite_bind_c(env,len(env)) endif else call ec_putenv_overwrite_bind_c(env,len(env)) endif end subroutine subroutine ec_setenv(key, value, overwrite) !! Set environment, with non-optional 'overwrite' argument which can be used to force or avoid overwriting if already set. !! Example: !! call ec_setenv("DR_HOOK","1",OVERWRITE=.TRUE.) ! Forces overwrite !! call ec_putenv("DR_HOOK","0",OVERWRITE=.FALSE) ! Will have no effect as DR_HOOK=1 already exists !! character(len=*), intent(in) :: key character(len=*), intent(in) :: value logical, intent(in) :: overwrite character(len=:), allocatable :: env env = trim(key)//'='//trim(value) if( overwrite ) then call ec_putenv_overwrite_bind_c(env,len(env)) else call ec_putenv_nooverwrite_bind_c(env,len(env)) endif end subroutine subroutine ec_getenv(key, value) !! Get environment variable by key. If key is not available, value argument will be filled with spaces. !! Example: !! CHARACTER(len=255) :: CENV_DR_HOOK !! call ec_getenv("DR_HOOK",CENV_DR_HOOK) !! character(len=*), intent(in) :: key character(len=*), intent(inout) :: value call ec_getenv_bind_c(key,value,len(key),len(value)) end subroutine function ec_numenv() result(value) !! Return number of environment variables !! use, intrinsic :: iso_c_binding, only : c_int integer(kind=c_int) :: value call ec_numenv_bind_c(value) end function subroutine ec_environ(i,value) !! Set value to entry of the unix "environ" variable with index 1..ec_numenv !! The content of value will be of form "KEY=VALUE", as in ec_putenv use, intrinsic :: iso_c_binding, only : c_int integer(kind=c_int), intent(in) :: i character(len=*), intent(inout) :: value call ec_environ_bind_c(i,value,len(value)) end subroutine end module fiat-ecmwf-2.0.0/src/fiat/util/xrd_unix_env.F900000664000175000017500000001021015157200431021366 0ustar alastairalastairMODULE XRD_UNIX_ENV !**** *XRD_UNIX_ENV* - ! Author. ! ------- ! Philippe Marguinaud *METEO FRANCE* ! Original : 11-09-2012 USE EC_PARKIND, ONLY : JPIM #ifdef NAGFOR use F90_UNIX, only: GETARG use F90_UNIX_PROC, only: EXIT #endif IMPLICIT NONE CONTAINS SUBROUTINE XRD_GETENV( KEY, VAL ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: KEY CHARACTER(LEN=*), INTENT(OUT) :: VAL CALL GET_ENVIRONMENT_VARIABLE( KEY, VAL ) END SUBROUTINE XRD_GETENV FUNCTION XRD_IARGC() IMPLICIT NONE INTEGER(KIND=JPIM) :: XRD_IARGC XRD_IARGC = COMMAND_ARGUMENT_COUNT() END FUNCTION XRD_IARGC SUBROUTINE XRD_GETARG( KEY, VAL ) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KEY CHARACTER(LEN=*), INTENT(OUT) :: VAL CALL GETARG( INT(KEY,SELECTED_INT_KIND(9)), VAL ) END SUBROUTINE XRD_GETARG SUBROUTINE XRD_EXIT( STATUS ) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: STATUS CALL EXIT( INT(STATUS,SELECTED_INT_KIND(9)) ) END SUBROUTINE XRD_EXIT SUBROUTINE XRD_MKDIR( PATH ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: PATH #ifdef NAGFOR CALL EXECUTE_COMMAND_LINE( "mkdir -p "//TRIM(PATH)) #else CALL SYSTEM( "mkdir -p "//TRIM(PATH)) #endif END SUBROUTINE XRD_MKDIR CHARACTER*256 FUNCTION XRD_DIRNAME( PATH ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: PATH INTEGER(KIND=JPIM) :: I XRD_DIRNAME = "" I = LEN( TRIM( PATH ) ) - 1 DO IF( I .LE. 0 ) RETURN IF( PATH(I:I) .EQ. '/' ) EXIT I = I - 1 ENDDO XRD_DIRNAME = PATH(1:I) END FUNCTION XRD_DIRNAME FUNCTION XRD_BASENAME( PATH ) IMPLICIT NONE CHARACTER*256 :: XRD_BASENAME CHARACTER(LEN=*), INTENT(IN) :: PATH INTEGER(KIND=JPIM) :: I XRD_BASENAME = "" I = LEN( TRIM( PATH ) ) - 1 DO IF( I .LE. 0 ) THEN I = 0 EXIT ENDIF IF( PATH(I:I) .EQ. '/' ) EXIT I = I - 1 ENDDO XRD_BASENAME = PATH(I+1:) END FUNCTION XRD_BASENAME ELEMENTAL SUBROUTINE XRD_LOWER_CASE(OUS,INS) IMPLICIT NONE ! CONVERT A WORD TO LOWER CASE CHARACTER (LEN=*) , INTENT(OUT) :: OUS CHARACTER (LEN=*) , INTENT(IN) :: INS INTEGER :: I,IC,NLEN NLEN = LEN(INS) OUS = '' DO I=1,NLEN IC = ICHAR(INS(I:I)) IF (IC >= 65 .AND. IC < 90) THEN OUS(I:I) = CHAR(IC+32) ELSE OUS(I:I) = INS(I:I) ENDIF END DO END SUBROUTINE XRD_LOWER_CASE ELEMENTAL SUBROUTINE XRD_UPPER_CASE(OUS,INS) IMPLICIT NONE ! CONVERT A WORD TO UPPER CASE CHARACTER (LEN=*) , INTENT(OUT) :: OUS CHARACTER (LEN=*) , INTENT(IN) :: INS INTEGER :: I,IC,NLEN NLEN = LEN(INS) OUS = '' DO I=1,NLEN IC = ICHAR(INS(I:I)) IF (IC >= 97 .AND. IC < 122) THEN OUS(I:I) = CHAR(IC-32) ELSE OUS(I:I) = INS(I:I) ENDIF END DO END SUBROUTINE XRD_UPPER_CASE FUNCTION XRD_ISALPHA(C) IMPLICIT NONE LOGICAL(KIND=JPIM) :: XRD_ISALPHA CHARACTER, INTENT(IN) :: C XRD_ISALPHA = ((C.GE.'A').AND.(C.LE.'Z'))& .OR.((C.GE.'a').AND.(C.LE.'z')) END FUNCTION XRD_ISALPHA FUNCTION XRD_ISDIGIT(C) IMPLICIT NONE LOGICAL(KIND=JPIM) :: XRD_ISDIGIT CHARACTER, INTENT(IN) :: C XRD_ISDIGIT = (C.GE.'0').AND.(C.LE.'9') END FUNCTION XRD_ISDIGIT SUBROUTINE XRD_DATE_AND_TIME( VL ) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(OUT) :: VL(8) ! INTEGER :: VLX(8) CALL DATE_AND_TIME( VALUES = VLX ) VL = VLX END SUBROUTINE XRD_DATE_AND_TIME SUBROUTINE XRD_CPU_TIME( T ) IMPLICIT NONE REAL,INTENT(OUT) :: T CALL CPU_TIME( T ) END SUBROUTINE XRD_CPU_TIME SUBROUTINE XRD_COUNTLINES( NLINES, F, ERR ) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(OUT) :: NLINES CHARACTER*(*), INTENT(IN) :: F INTEGER(KIND=JPIM), INTENT(OUT) :: ERR CHARACTER*32 :: STR ERR = 0 NLINES = 0 OPEN( 77, FILE = F, ERR = 888 ) DO READ( 77, *, ERR = 888, END = 777 ) STR NLINES = NLINES + 1 ENDDO 777 CONTINUE CLOSE( 77 ) RETURN 888 CONTINUE ERR = 1 END SUBROUTINE XRD_COUNTLINES FUNCTION XRD_COUNTWORDS( S ) IMPLICIT NONE INTEGER(KIND=JPIM) :: XRD_COUNTWORDS CHARACTER(LEN=*), INTENT(IN) :: S INTEGER(KIND=JPIM) :: N, I, L LOGICAL(KIND=JPIM) :: IN N = 0_JPIM IN = .FALSE. L = LEN( TRIM( S ) ) DO I = 1, L IF( S(I:I) .EQ. ' ' ) THEN IN = .FALSE. ELSE IF( .NOT. IN ) THEN N = N + 1 IN = .TRUE. ENDIF ENDDO XRD_COUNTWORDS = N END FUNCTION XRD_COUNTWORDS END MODULE XRD_UNIX_ENV fiat-ecmwf-2.0.0/src/fiat/util/byteswap.c0000664000175000017500000000262615157200431020414 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include static const char * T = "abcd"; static const int dTle = 0x64636261; static const int dTbe = 0x61626364; void iswap_isle_ (int * reqd) { int * dT = (int *)T; if (*dT == dTle) *reqd = 1; else *reqd = 0; } // iswap will swap your buffer (LE -> BE) if your system is little-endian, // otherwise, just make a copy. void iswap (char * a, const char * b, int t, int n, int d) { int i, j; if (d) { for (i = 0; i < n; i++) { for (j = 0; j < t / 2; j++) { char c = b[i*t+j]; /* a and b may be the same */ a[i*t+j] = b[i*t+t-j-1]; a[i*t+t-j-1] = c; } } } else if (a != b) { size_t nbytes = t * n; memcpy (a, b, nbytes); } } void iswap_ (char * a, const char * b, const int * _t, const int * _n) { int * dT = (int *)T; iswap (a, b, *_t, *_n, *dT == dTle); } // jswap will make a LE->BE transform. void jswap_ (char * a, const char * b, const int * _t, const int * _n) { iswap (a, b, *_t, *_n, 1); } fiat-ecmwf-2.0.0/src/fiat/util/timef.F900000664000175000017500000000320315157200431017766 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! #if defined ( _CRAYFTN ) REAL*8 FUNCTION TIMEF() INTEGER*8 I_TIME1,I_RATE REAL*8 ZTIMEF,ZFIRST DATA IFIRST/0/ SAVE IFIRST,ZFIRST ! THIS IS A REAL TIME CLOCK IN MILLISECONDS. ! USAGE OF FORTRAN90 INTRINSIC FUNCTION. CALL SYSTEM_CLOCK (COUNT=I_TIME1,COUNT_RATE=I_RATE) ZTIMEF=DFLOAT(I_TIME1)/DFLOAT(I_RATE) IF(IFIRST.EQ.0) THEN IFIRST=1 ZFIRST=ZTIMEF TIMEF=0.0 ELSE TIMEF=1000.0*(ZTIMEF-ZFIRST) ENDIF RETURN ENDFUNCTION TIMEF #else FUNCTION TIMEF() !ss: Uses util_walltime_() from DrHook -- ! Should now have higher precision (avoiding negative accum. wall-time in ifs.stat (see opdis.F90)) USE EC_PARKIND, ONLY : JPIM, JPRD IMPLICIT NONE REAL(KIND=JPRD) :: TIMEF REAL(KIND=JPRD) :: ZTIMEF REAL(KIND=JPRD),SAVE :: ZFIRST INTEGER(KIND=JPIM),SAVE :: IFIRST = 0 REAL(KIND=JPRD), EXTERNAL :: UTIL_WALLTIME ! ifsaux/support/drhook.c ZTIMEF = UTIL_WALLTIME() IF(IFIRST.EQ.0) THEN IFIRST=1 ZFIRST=ZTIMEF TIMEF=0.0_JPRD ELSE TIMEF=1000.0_JPRD * (ZTIMEF-ZFIRST) ENDIF ENDFUNCTION TIMEF #endif fiat-ecmwf-2.0.0/src/fiat/util/ec_pmon.F900000664000175000017500000000325215157200431020306 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE EC_PMON(ENERGY,POWER) USE EC_PARKIND, ONLY : JPIM, JPIB IMPLICIT NONE INTEGER(KIND=JPIB),INTENT(OUT) :: ENERGY,POWER INTEGER(KIND=JPIB),SAVE :: ENERGY_START = 0 INTEGER(KIND=JPIM),SAVE :: MONINIT = 0 INTEGER(KIND=JPIM) :: ISTAT CHARACTER(LEN=1) :: CLEC_PMON ENERGY = 0 IF (MONINIT >= 0) THEN IF (MONINIT == 0) THEN ! The very first time only CALL GET_ENVIRONMENT_VARIABLE('EC_PMON',CLEC_PMON) IF (CLEC_PMON == '0') MONINIT = -2 ! Never try again ENDIF IF (MONINIT >= 0) THEN OPEN(503,FILE='/sys/cray/pm_counters/energy',IOSTAT=ISTAT,STATUS='old',ACTION='read') IF (ISTAT == 0) THEN READ(503,*,IOSTAT=ISTAT) ENERGY CLOSE(503) IF (ISTAT == 0) THEN IF (MONINIT == 0) THEN ENERGY_START = ENERGY MONINIT = 1 ! Ok ENDIF ENERGY = ENERGY - ENERGY_START ENDIF ENDIF IF (ISTAT /= 0) THEN MONINIT = -1 ! Never try again ENERGY = 0 ENDIF ENDIF ENDIF POWER = 0 IF (MONINIT > 0) THEN OPEN(504,FILE='/sys/cray/pm_counters/power',IOSTAT=ISTAT,STATUS='old',ACTION='read') IF (ISTAT == 0) THEN READ(504,*,IOSTAT=ISTAT) POWER CLOSE(504) ENDIF IF (ISTAT /= 0) POWER = 0 ENDIF END SUBROUTINE EC_PMON fiat-ecmwf-2.0.0/src/fiat/util/qsortc.F900000664000175000017500000000441315157200431020201 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2005- Meteo France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! ! Sort character strings SUBROUTINE QSORTC (N,ORD,A) USE EC_PARKIND, ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: N INTEGER(KIND=JPIM), INTENT(INOUT) :: ORD(N) CHARACTER(LEN=*), INTENT(IN) :: A(N) INTEGER(KIND=JPIM) :: I,IP,IQ,IX,IZ,L,L1,NDEEP,P INTEGER(KIND=JPIM) :: POPLST(2,20) INTEGER(KIND=JPIM) :: Q,U,U1,YP CHARACTER(LEN=LEN(A)) :: X,XX,Z,ZZ,Y NDEEP=0 U1=N L1=1 DO I=1,N ORD(I)=I ENDDO 2 IF (U1.LE.L1) RETURN 3 L=L1 U=U1 4 P=L Q=U X=A(ORD(P)) Z=A(ORD(Q)) IF (X.LE.Z) GO TO 5 Y=X X=Z Z=Y YP=ORD(P) ORD(P)=ORD(Q) ORD(Q)=YP 5 IF (U-L.LE.1) GO TO 15 XX=X IX=P ZZ=Z IZ=Q 6 P=P+1 IF (P.GE.Q) GO TO 7 X=A(ORD(P)) IF (X.GE.XX) GO TO 8 GO TO 6 7 P=Q-1 GO TO 13 8 Q=Q-1 IF (Q.LE.P) GO TO 9 Z=A(ORD(Q)) IF (Z.LE.ZZ) GO TO 10 GO TO 8 9 Q=P P=P-1 Z=X X=A(ORD(P)) 10 IF (X.LE.Z) GO TO 11 Y=X X=Z Z=Y IP=ORD(P) ORD(P)=ORD(Q) ORD(Q)=IP 11 IF (X.LE.XX) GO TO 12 XX=X IX=P 12 IF (Z.GE.ZZ) GO TO 6 ZZ=Z IZ=Q GO TO 6 13 CONTINUE IF (.NOT.(P.NE.IX.AND.X.NE.XX)) GO TO 14 IP=ORD(P) ORD(P)=ORD(IX) ORD(IX)=IP 14 CONTINUE IF (.NOT.(Q.NE.IZ.AND.Z.NE.ZZ)) GO TO 15 IQ=ORD(Q) ORD(Q)=ORD(IZ) ORD(IZ)=IQ 15 CONTINUE IF (U-Q.LE.P-L) GO TO 16 L1=L U1=P-1 L=Q+1 GO TO 17 16 U1=U L1=Q+1 U=P-1 17 CONTINUE IF (U1.LE.L1) GO TO 18 NDEEP=NDEEP+1 POPLST(1,NDEEP)=U POPLST(2,NDEEP)=L GO TO 3 18 IF (U.GT.L) GO TO 4 IF (NDEEP.EQ.0) GO TO 2 U=POPLST(1,NDEEP) L=POPLST(2,NDEEP) NDEEP=NDEEP-1 GO TO 18 END SUBROUTINE QSORTC fiat-ecmwf-2.0.0/src/fiat/util/bytes_io_mod.F900000664000175000017500000010546615157200431021354 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE BYTES_IO_MOD !**** Interface to BYTES_IO ! Purpose. ! -------- ! Fortran 90 Interface to calling byte IO ! Author. ! ------- ! W.Deconinck and M.Hamrud ECMWF ! Modifications. ! -------------- ! Original: 2016-01-28 ! ------------------------------------------------------------------ USE EC_PARKIND , ONLY : JPRD, JPIM, JPIB, JPRM USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY : MPL_ABORT IMPLICIT NONE PRIVATE :: JPRD, JPIM, JPIB, JPRM PRIVATE :: LHOOK, DR_HOOK PRIVATE :: MPL_ABORT PRIVATE INTERFACE BYTES_IO_READ MODULE PROCEDURE BYTES_IO_READ_JPIM_INT MODULE PROCEDURE BYTES_IO_READ_JPIM_INT_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIM_REAL4 MODULE PROCEDURE BYTES_IO_READ_JPIM_REAL4_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIM_REAL4_ARRAY2 MODULE PROCEDURE BYTES_IO_READ_JPIM_REAL8 MODULE PROCEDURE BYTES_IO_READ_JPIM_REAL8_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIM_REAL8_ARRAY2 MODULE PROCEDURE BYTES_IO_READ_JPIM_CHAR_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIB_INT MODULE PROCEDURE BYTES_IO_READ_JPIB_INT_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIB_REAL4 MODULE PROCEDURE BYTES_IO_READ_JPIB_REAL4_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIB_REAL4_ARRAY2 MODULE PROCEDURE BYTES_IO_READ_JPIB_REAL8 MODULE PROCEDURE BYTES_IO_READ_JPIB_REAL8_ARRAY MODULE PROCEDURE BYTES_IO_READ_JPIB_REAL8_ARRAY2 MODULE PROCEDURE BYTES_IO_READ_JPIB_CHAR_ARRAY END INTERFACE INTERFACE BYTES_IO_WRITE MODULE PROCEDURE BYTES_IO_WRITE_JPIM_INT MODULE PROCEDURE BYTES_IO_WRITE_JPIM_INT_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIM_REAL4 MODULE PROCEDURE BYTES_IO_WRITE_JPIM_REAL4_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIM_REAL4_ARRAY2 MODULE PROCEDURE BYTES_IO_WRITE_JPIM_REAL8 MODULE PROCEDURE BYTES_IO_WRITE_JPIM_REAL8_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIM_REAL8_ARRAY2 MODULE PROCEDURE BYTES_IO_WRITE_JPIM_CHAR_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIB_INT MODULE PROCEDURE BYTES_IO_WRITE_JPIB_INT_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIB_REAL4 MODULE PROCEDURE BYTES_IO_WRITE_JPIB_REAL4_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIB_REAL4_ARRAY2 MODULE PROCEDURE BYTES_IO_WRITE_JPIB_REAL8 MODULE PROCEDURE BYTES_IO_WRITE_JPIB_REAL8_ARRAY MODULE PROCEDURE BYTES_IO_WRITE_JPIB_REAL8_ARRAY2 MODULE PROCEDURE BYTES_IO_WRITE_JPIB_CHAR_ARRAY END INTERFACE PUBLIC :: BYTES_IO_OPEN PUBLIC :: BYTES_IO_CLOSE PUBLIC :: BYTES_IO_WRITE PUBLIC :: BYTES_IO_READ PUBLIC :: BYTES_IO_SEEK PUBLIC :: BYTES_IO_TELL PUBLIC :: BYTES_IO_FLUSH INTEGER, PARAMETER, PUBLIC :: JPBYTES_IO_SUCCESS=0 INTEGER, PARAMETER :: JPBYTES_IO_COULD_NOT_OPEN_FILE=-1 INTEGER, PARAMETER :: JPBYTES_IO_COULD_NOT_CLOSE_FILE=-1 INTEGER, PARAMETER :: JPBYTES_IO_INVALID_FILE_NAME=-2 INTEGER, PARAMETER :: JPBYTES_IO_INVALID_OPEN_MODE=-3 INTEGER, PARAMETER :: JPBYTES_IO_END_OF_FILE=-1 INTEGER, PARAMETER :: JPBYTES_IO_SEEK_ERROR=-2 INTEGER, PARAMETER :: JPBYTES_IO_READ_JPIM_ERROR=-2 INTEGER, PARAMETER :: JPBYTES_IO_WRITE_JPIM_ERROR=-1 CONTAINS SUBROUTINE BYTES_IO_OPEN(KFILE,CDPATH,CDMODE,KRET) INTEGER(KIND=JPIM),INTENT(OUT) :: KFILE CHARACTER(LEN=*) ,INTENT(IN) :: CDPATH CHARACTER(LEN=1) ,INTENT(IN) :: CDMODE INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_OPEN',0,ZHOOK_HANDLE) CALL C_BYTES_IO_OPEN(KFILE,CDPATH,CDMODE,IRET) IF(PRESENT(KRET)) THEN KRET = IRET ELSEIF (IRET < JPBYTES_IO_SUCCESS) THEN WRITE(0,*) 'BYTES_IO ',TRIM(CDPATH),' FAILED',IRET CALL MPL_ABORT('BYTES_IO_OPEN FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_OPEN',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_OPEN SUBROUTINE BYTES_IO_CLOSE(KFILE,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_CLOSE',0,ZHOOK_HANDLE) CALL C_BYTES_IO_CLOSE(KFILE,IRET) IF(PRESENT(KRET)) THEN KRET = IRET ELSEIF (IRET < JPBYTES_IO_SUCCESS) THEN WRITE(0,*) 'BYTES_IO_CLOSE ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_CLOSE FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_CLOSE',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_CLOSE SUBROUTINE BYTES_IO_FLUSH(KFILE) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_FLUSH',0,ZHOOK_HANDLE) CALL C_BYTES_IO_FLUSH(KFILE) IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_FLUSH',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_FLUSH SUBROUTINE BYTES_IO_SEEK(KFILE,KOFFSET,KWHENCE,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(IN) :: KOFFSET INTEGER(KIND=JPIM),INTENT(IN) :: KWHENCE INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_SEEK',0,ZHOOK_HANDLE) CALL C_BYTES_IO_SEEK(KFILE,KOFFSET,KWHENCE,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS) THEN WRITE(0,*) 'BYTES_IO_SEEK ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_SEEK FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_SEEK',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_SEEK SUBROUTINE BYTES_IO_TELL(KFILE,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_SEEK',0,ZHOOK_HANDLE) CALL C_BYTES_IO_TELL(KFILE,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS) THEN WRITE(0,*) 'BYTES_IO_TELL ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_TELL FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_TELL',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_TELL ! ============================================ ! BYTES_IO_READ_JPIM SUBROUTINE BYTES_IO_READ_JPIM_INT(KFILE,KBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(OUT) :: KBUF INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_INT',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,KBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_INT ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_INT FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_INT',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_INT SUBROUTINE BYTES_IO_READ_JPIM_INT_ARRAY(KFILE,KBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(OUT) :: KBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_INT_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,KBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_INT_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_INT_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_INT_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_INT_ARRAY SUBROUTINE BYTES_IO_READ_JPIM_REAL4(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(OUT) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL4',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_REAL4 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_REAL4 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL4',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_REAL4 SUBROUTINE BYTES_IO_READ_JPIM_REAL4_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(OUT) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL4_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_REAL4_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_REAL4_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL4_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_REAL4_ARRAY SUBROUTINE BYTES_IO_READ_JPIM_REAL4_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(OUT) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL4_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_REAL4_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_REAL4_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL4_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_REAL4_ARRAY2 SUBROUTINE BYTES_IO_READ_JPIM_REAL8(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(OUT) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL8',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_REAL8 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_REAL8 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL8',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_REAL8 SUBROUTINE BYTES_IO_READ_JPIM_REAL8_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(OUT) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL8_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_REAL8_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_REAL8_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL8_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_REAL8_ARRAY SUBROUTINE BYTES_IO_READ_JPIM_REAL8_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(OUT) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL8_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_REAL8_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_REAL8_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_REAL8_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_REAL8_ARRAY2 SUBROUTINE BYTES_IO_READ_JPIM_CHAR_ARRAY(KFILE,CDBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE CHARACTER(LEN=1) ,INTENT(OUT) :: CDBUF(:) INTEGER(KIND=JPIM),INTENT(INOUT) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_CHAR_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,CDBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIM_CHAR_ARRAY ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIM_CHAR_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIM_CHAR_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIM_CHAR_ARRAY ! ============================================ ! BYTES_IO_WRITE_JPIM SUBROUTINE BYTES_IO_WRITE_JPIM_INT(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(IN) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_INT',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_INT ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_INT FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_INT',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_INT SUBROUTINE BYTES_IO_WRITE_JPIM_INT_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(IN) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_INT',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_INT ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_INT FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_INT',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_INT_ARRAY SUBROUTINE BYTES_IO_WRITE_JPIM_REAL4(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(IN) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL4',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_REAL4 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_REAL4 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL4',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_REAL4 SUBROUTINE BYTES_IO_WRITE_JPIM_REAL4_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(IN) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL4_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_REAL4_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_REAL4_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL4_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_REAL4_ARRAY SUBROUTINE BYTES_IO_WRITE_JPIM_REAL4_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(IN) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL4_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_REAL4_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_REAL4_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL4_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_REAL4_ARRAY2 SUBROUTINE BYTES_IO_WRITE_JPIM_REAL8(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(IN) :: PBUF INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL8',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_REAL8 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_REAL8 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL8',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_REAL8 SUBROUTINE BYTES_IO_WRITE_JPIM_REAL8_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(IN) :: PBUF(:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL8_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_REAL8_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_REAL8_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL8_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_REAL8_ARRAY SUBROUTINE BYTES_IO_WRITE_JPIM_REAL8_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(IN) :: PBUF(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL8_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_REAL8_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_REAL8_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_REAL8_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_REAL8_ARRAY2 SUBROUTINE BYTES_IO_WRITE_JPIM_CHAR_ARRAY(KFILE,CDBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE CHARACTER(LEN=1) ,INTENT(IN) :: CDBUF(:) INTEGER(KIND=JPIM),INTENT(INOUT) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_CHAR_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,CDBUF,KBYTES,IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIM_CHAR_ARRAY ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIM_CHAR_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIM_CHAR_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIM_CHAR_ARRAY ! ============================================ ! BYTES_IO_READ_JPIB SUBROUTINE BYTES_IO_READ_JPIB_INT(KFILE,KBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(OUT) :: KBUF INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_INT',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,KBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_INT ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_INT FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_INT',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_INT SUBROUTINE BYTES_IO_READ_JPIB_INT_ARRAY(KFILE,KBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(OUT) :: KBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_INT_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,KBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_INT_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_INT_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_INT_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_INT_ARRAY SUBROUTINE BYTES_IO_READ_JPIB_REAL4(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(OUT) :: PBUF INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL4',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_REAL4 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_REAL4 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL4',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_REAL4 SUBROUTINE BYTES_IO_READ_JPIB_REAL4_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(OUT) :: PBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL4_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_REAL4_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_REAL4_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL4_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_REAL4_ARRAY SUBROUTINE BYTES_IO_READ_JPIB_REAL4_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(OUT) :: PBUF(:,:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL4_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_REAL4_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_REAL4_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL4_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_REAL4_ARRAY2 SUBROUTINE BYTES_IO_READ_JPIB_REAL8(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(OUT) :: PBUF INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL8',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_REAL8 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_REAL8 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL8',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_REAL8 SUBROUTINE BYTES_IO_READ_JPIB_REAL8_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(OUT) :: PBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL8_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_REAL8_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_REAL8_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL8_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_REAL8_ARRAY SUBROUTINE BYTES_IO_READ_JPIB_REAL8_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(OUT) :: PBUF(:,:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL8_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_REAL8_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_REAL8_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_REAL8_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_REAL8_ARRAY2 SUBROUTINE BYTES_IO_READ_JPIB_CHAR_ARRAY(KFILE,CDBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE CHARACTER(LEN=1) ,INTENT(OUT) :: CDBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET,ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_CHAR_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_READ(KFILE,CDBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS .AND. IRET < JPBYTES_IO_END_OF_FILE ) THEN WRITE(0,*) 'BYTES_IO_READ_JPIB_CHAR_ARRAY ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_READ_JPIB_CHAR_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_READ_JPIB_CHAR_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_READ_JPIB_CHAR_ARRAY ! ============================================ ! BYTES_IO_WRITE_JPIB SUBROUTINE BYTES_IO_WRITE_JPIB_INT(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(IN) :: PBUF INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_INT',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_INT ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_INT FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_INT',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_INT SUBROUTINE BYTES_IO_WRITE_JPIB_INT_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE INTEGER(KIND=JPIM),INTENT(IN) :: PBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_INT',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_INT ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_INT FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_INT',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_INT_ARRAY SUBROUTINE BYTES_IO_WRITE_JPIB_REAL4(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(IN) :: PBUF INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL4',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_REAL4 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_REAL4 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL4',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_REAL4 SUBROUTINE BYTES_IO_WRITE_JPIB_REAL4_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(IN) :: PBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL4_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_REAL4_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_REAL4_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL4_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_REAL4_ARRAY SUBROUTINE BYTES_IO_WRITE_JPIB_REAL4_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRM),INTENT(IN) :: PBUF(:,:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL4_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_REAL4_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_REAL4_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL4_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_REAL4_ARRAY2 SUBROUTINE BYTES_IO_WRITE_JPIB_REAL8(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(IN) :: PBUF INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL8',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_REAL8 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_REAL8 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL8',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_REAL8 SUBROUTINE BYTES_IO_WRITE_JPIB_REAL8_ARRAY(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(IN) :: PBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL8_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_REAL8_ARRAY ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_REAL8_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL8_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_REAL8_ARRAY SUBROUTINE BYTES_IO_WRITE_JPIB_REAL8_ARRAY2(KFILE,PBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE REAL(KIND=JPRD),INTENT(IN) :: PBUF(:,:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KRET INTEGER(KIND=JPIM) :: IRET INTEGER(KIND=JPIM) :: ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL8_ARRAY2',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,PBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ENDIF IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_REAL8_ARRAY2 ',KFILE,' ',KBYTES,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_REAL8_ARRAY2 FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_REAL8_ARRAY2',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_REAL8_ARRAY2 SUBROUTINE BYTES_IO_WRITE_JPIB_CHAR_ARRAY(KFILE,CDBUF,KBYTES,KRET) INTEGER(KIND=JPIM),INTENT(IN) :: KFILE CHARACTER(LEN=1) ,INTENT(IN) :: CDBUF(:) INTEGER(KIND=JPIB),INTENT(IN) :: KBYTES INTEGER(KIND=JPIM),INTENT(OUT), OPTIONAL :: KRET INTEGER(KIND=JPIM) :: IRET REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_CHAR_ARRAY',0,ZHOOK_HANDLE) CALL C_BYTES_IO_WRITE(KFILE,CDBUF,INT(KBYTES,JPIM),IRET) IF(PRESENT(KRET)) THEN KRET=IRET ELSEIF(IRET < JPBYTES_IO_SUCCESS) THEN WRITE(0,*) 'BYTES_IO_WRITE_JPIB_CHAR_ARRAY ',KFILE,' FAILED',IRET CALL MPL_ABORT('BYTES_IO_WRITE_JPIB_CHAR_ARRAY FAILED') ENDIF IF (LHOOK) CALL DR_HOOK('BYTES_IO:BYTES_IO_WRITE_JPIB_CHAR_ARRAY',1,ZHOOK_HANDLE) END SUBROUTINE BYTES_IO_WRITE_JPIB_CHAR_ARRAY END MODULE BYTES_IO_MOD fiat-ecmwf-2.0.0/src/fiat/util/ec_datetime.c0000664000175000017500000003427715157200431021030 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* Modified by Willem Deconinck to be more portable using standard integers. - Originally this file was part of eclib - Then was ifsaux/eclite/julian.h - Now part of fiat */ #define EC_DATETIME_C #include "julian.h" /******************************* * Declarations *******************************/ #define CD2DATE cd2date #define YD2DATE yd2date #define IDATE2CD idate2cd #define IDATE2YD idate2yd #define ICD2YMD icd2ymd #define IYMD2CD iymd2cd #define DAYDIFF daydiff #define HOURDIFF hourdiff #define MINDIFF mindiff #define SECDIFF secdiff #define DAYINCR dayincr #define HOURINCR hourincr #define MININCR minincr #define SECINCR secincr void CD2DATE(const int32_t *const icd, int32_t *const iy, int32_t *const im, int32_t *const id, int32_t *const iret); void YD2DATE(const int32_t *const iyd, const int32_t *const iy, int32_t *const im, int32_t *const id, int32_t *const iret); int32_t IDATE2CD(const int32_t *const iy, const int32_t *const im, const int32_t *const id, int32_t *const iret); int32_t IDATE2YD(const int32_t *const iy, const int32_t *const im, const int32_t *const id, int32_t *const iret); int32_t ICD2YMD(const int32_t *const icd, int32_t *const iret); int32_t IYMD2CD(const int32_t *const iymd, int32_t *const iret); void DAYDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, int32_t *const days, int32_t *const iret); void HOURDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, int32_t *const hours, int32_t *const iret); void MINDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, const int32_t *const min1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, const int32_t *const min2, int32_t *const minutes, int32_t *const iret); void SECDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, const int32_t *const min1, const int32_t *const sec1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, const int32_t *const min2, const int32_t *const sec2, int32_t *const seconds, int32_t *const iret); void HOURINCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, const int32_t *const hours,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, int32_t *const iret); void MININCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, const int32_t *const min, const int32_t *const minutes,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, int32_t *const new_min, int32_t *const iret); void SECINCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, const int32_t *const min, const int32_t *const sec, const int32_t *const seconds,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, int32_t *const new_min, int32_t *const new_sec, int32_t *const iret); /******************************* * Definitions *******************************/ void DAYDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, int32_t *const days, int32_t *const iret) { yyyymmdd_t date1_str = {0,0,0}, date2_str = {0,0,0}; exit_t exit_status = 0; *days = 0; date1_str.year = *year1; date1_str.month = *month1; date1_str.day = *day1; date2_str.year = *year2; date2_str.month = *month2; date2_str.day = *day2; if ( (exit_status = dateMinusDate(&date1_str, &date2_str, days)) != EC_OK) { *iret = exit_status; return; } *iret = EC_OK; return; } /* DAYDIFF */ void HOURDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, int32_t *const hours, int32_t *const iret) { yyyymmdd_t date1_str = {0,0,0}, date2_str = {0,0,0}; hhmmss_t hms1_str = {0,0,0}, hms2_str = {0,0,0}; exit_t exit_status = 0; *hours = 0; date1_str.year = *year1; date1_str.month = *month1; date1_str.day = *day1; hms1_str.hour = *hour1; date2_str.year = *year2; date2_str.month = *month2; date2_str.day = *day2; hms2_str.hour = *hour2; if ( (exit_status = hour_dateMinusDate(&date1_str, &hms1_str, &date2_str, &hms2_str, hours)) != EC_OK) { *iret = exit_status; return; } *iret = EC_OK; return; } /* HOURDIFF */ void MINDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, const int32_t *const min1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, const int32_t *const min2, int32_t *const minutes, int32_t *const iret) { yyyymmdd_t date1_str = {0,0,0}, date2_str = {0,0,0}; hhmmss_t hms1_str = {0,0,0}, hms2_str = {0,0,0}; exit_t exit_status = 0; *minutes = 0; date1_str.year = *year1; date1_str.month = *month1; date1_str.day = *day1; hms1_str.hour = *hour1; hms1_str.min = *min1; date2_str.year = *year2; date2_str.month = *month2; date2_str.day = *day2; hms2_str.hour = *hour2; hms2_str.min = *min2; if ( (exit_status = min_dateMinusDate(&date1_str, &hms1_str, &date2_str, &hms2_str, minutes)) != EC_OK) { *iret = exit_status; return; } *iret = EC_OK; return; } /* MINDIFF */ void SECDIFF(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, const int32_t *const min1, const int32_t *const sec1, const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, const int32_t *const min2, const int32_t *const sec2, int32_t *const seconds, int32_t *const iret) { yyyymmdd_t date1_str = {0,0,0}, date2_str = {0,0,0}; hhmmss_t hms1_str = {0,0,0}, hms2_str = {0,0,0}; exit_t exit_status = 0; *seconds = 0; date1_str.year = *year1; date1_str.month = *month1; date1_str.day = *day1; hms1_str.hour = *hour1; hms1_str.min = *min1; hms1_str.sec = *sec1; date2_str.year = *year2; date2_str.month = *month2; date2_str.day = *day2; hms2_str.hour = *hour2; hms2_str.min = *min2; hms2_str.sec = *sec2; if ( (exit_status = sec_dateMinusDate(&date1_str, &hms1_str, &date2_str, &hms2_str, seconds)) != EC_OK) { *iret = exit_status; return; } *iret = EC_OK; return; } /* SECDIFF */ void DAYINCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const days, int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}, new_date_str = {0,0,0}; exit_t exit_status = 0; date_str.year = *year; date_str.month = *month; date_str.day = *day; if ( (exit_status = addDays(&date_str, *days, &new_date_str)) != EC_OK) { *iret = exit_status; return; } *new_year = new_date_str.year; *new_month = new_date_str.month; *new_day = new_date_str.day; *iret = EC_OK; return; } /* DAYINCR */ void HOURINCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, const int32_t *const hours,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}, new_date_str = {0,0,0}; hhmmss_t hms_str = {0,0,0}, new_hms_str = {0,0,0}; exit_t exit_status = 0; date_str.year = *year; date_str.month = *month; date_str.day = *day; hms_str.hour = *hour; if ( (exit_status = addHours(&date_str, &hms_str, *hours, &new_date_str, &new_hms_str)) != EC_OK) { *iret = exit_status; return; } *new_year = new_date_str.year; *new_month = new_date_str.month; *new_day = new_date_str.day; *new_hour = new_hms_str.hour; *iret = EC_OK; return; } /* HOURINCR */ void MININCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, const int32_t *const min, const int32_t *const minutes,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, int32_t *const new_min, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}, new_date_str = {0,0,0}; hhmmss_t hms_str = {0,0,0}, new_hms_str = {0,0,0}; exit_t exit_status = 0; date_str.year = *year; date_str.month = *month; date_str.day = *day; hms_str.hour = *hour; hms_str.min = *min; if ( (exit_status = addMinutes(&date_str, &hms_str, *minutes, &new_date_str, &new_hms_str)) != EC_OK) { *iret = exit_status; return; } *new_year = new_date_str.year; *new_month = new_date_str.month; *new_day = new_date_str.day; *new_hour = new_hms_str.hour; *new_min = new_hms_str.min; *iret = EC_OK; return; } /* MININCR */ void SECINCR(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, const int32_t *const min, const int32_t *const sec, const int32_t *const seconds,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, int32_t *const new_min, int32_t *const new_sec, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}, new_date_str = {0,0,0}; hhmmss_t hms_str = {0,0,0}, new_hms_str = {0,0,0}; exit_t exit_status = 0; date_str.year = *year; date_str.month = *month; date_str.day = *day; hms_str.hour = *hour; hms_str.min = *min; hms_str.sec = *sec; if ( (exit_status = addSeconds(&date_str, &hms_str, *seconds, &new_date_str, &new_hms_str)) != EC_OK) { *iret = exit_status; return; } *new_year = new_date_str.year; *new_month = new_date_str.month; *new_day = new_date_str.day; *new_hour = new_hms_str.hour; *new_min = new_hms_str.min; *new_sec = new_hms_str.sec; *iret = EC_OK; return; } /* SECINCR */ void CD2DATE(const int32_t *const icd, int32_t *const iy, int32_t *const im, int32_t *const id, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}; exit_t exit_status = 0; *iret = 0; if ( ( exit_status = centuryToDate(*icd, &date_str)) != EC_OK) { *iret = exit_status; return; } *id = date_str.day; *im = date_str.month; *iy = date_str.year; *iret = EC_OK; return; } /* CD2DATE */ void YD2DATE(const int32_t *const iyd, const int32_t *const iy, int32_t *const im, int32_t *const id, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}; exit_t exit_status = 0; if ( ( exit_status = yeardayToDate(*iyd, *iy, &date_str)) != EC_OK) { *iret = exit_status; return; } *id = date_str.day; *im = date_str.month; *iret = EC_OK; return; } /* YD2DATE */ int32_t IDATE2CD(const int32_t *const iy, const int32_t *const im, const int32_t *const id, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}; int32_t century = 0; exit_t exit_status = 0; date_str.year = *iy; date_str.month = *im; date_str.day = *id; if ( ( exit_status = dateToCentury( &date_str, ¢ury)) != EC_OK) { *iret = exit_status; return (0); } *iret = EC_OK; return (century); } /* IDATE2CD */ int32_t IDATE2YD(const int32_t *const iy, const int32_t *const im, const int32_t *const id, int32_t *const iret) { yyyymmdd_t date_str = {0,0,0}; int32_t yearday = 0; exit_t exit_status = 0; date_str.year = *iy; date_str.month = *im; date_str.day = *id; if ( ( exit_status = dateToYearday( &date_str, &yearday)) != EC_OK) { *iret = exit_status; return (0); } *iret = EC_OK; return (yearday); } /* IDATE2YD */ int32_t ICD2YMD(const int32_t *const icd, int32_t *const iret) { int32_t id, im, iy; int64_t ymd = 0; int32_t iymd = 0; id = 0; im = 0; iy = 0; *iret = 0; CD2DATE(icd, &iy, &im, &id, iret); if ( *iret != EC_OK) { return (0); } ymd = iy * 10000 + im * 100 + id; if ( ymd > INT32_MAX || ymd < INT32_MIN) { err_msg("ICD2YMD: ymd = %lld", (long long int)ymd); err_msg("Exceeded the allowed range"); *iret = EC_RANGE; return (0); } iymd = (int32_t) ymd; *iret = EC_OK; return (iymd); } /* ICD2YMD */ int32_t IYMD2CD(const int32_t *const iymd, int32_t *const iret) { int32_t id, im, iy, ymd; int32_t icd = 0; *iret = 0; ymd = *iymd; iy = ymd / 10000; ymd %= 10000; im = ymd / 100; ymd %= 100; id = ymd; icd = IDATE2CD(&iy, &im, &id, iret); if ( *iret != EC_OK) { return (0); } return (icd); } /* IYMD2CD */ fiat-ecmwf-2.0.0/src/fiat/util/ec_lun.F900000664000175000017500000000154315157200431020134 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE EC_LUN USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE SAVE PRIVATE :: JPIM PUBLIC ! ------------------------------------------------------------------ !* Logical units used by code ! NULOUT : output unit ! NULERR : unit number for comparison with reference run INTEGER(KIND=JPIM) :: NULOUT = 6 INTEGER(KIND=JPIM) :: NULERR = 0 ! ------------------------------------------------------------------ END MODULE EC_LUN fiat-ecmwf-2.0.0/src/fiat/util/user_clock.F900000664000175000017500000000503615157200431021021 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE USER_CLOCK(PELAPSED_TIME,PELAPSED_TIME_SINCE,PVECTOR_CP,PTOTAL_CP) !**** *USER_CLOCK* - interface to system dependent timer routines ! Purpose. ! -------- ! Returns elapsed and CP from the start of execution. ! Elapsed time is made relative to the first call to USER_CLOCK. !** Interface. ! ---------- ! ZTIME=USER_CLOCK(PELAPSED_TIME,PELAPSED_TIME_SINCE, ! PVECTOR_CP,PTOTAL_CP) ! Explicit arguments: (All are optional arguments) ! PELAPSED_TIME=wall clock time (seconds) ! PELAPSED_TIME_SINCE=wall clock time (seconds) ! change from input value of this parameter ! PVECTOR_CP=CP vector time (seconds) ! PTOTAL_CP=total CP time (seconds) ! Author. ! ------- ! D.Dent *ECMWF* ! External References: ! ------------------- ! TIMEF,CPTIME ! Modifications. ! -------------- ! Original : 97-09-25 ! F. Vana 05-Mar-2015 Support for single precision ! ---------------------------------------------------------- USE EC_PARKIND ,ONLY : JPRD, JPIM IMPLICIT NONE REAL(KIND=JPRD),INTENT(OUT) :: PELAPSED_TIME,PVECTOR_CP,PTOTAL_CP REAL(KIND=JPRD),INTENT(INOUT) :: PELAPSED_TIME_SINCE OPTIONAL PELAPSED_TIME,PELAPSED_TIME_SINCE OPTIONAL PVECTOR_CP,PTOTAL_CP REAL(KIND=JPRD) :: ZVECTOR_CP,ZTOTAL_CP,ZWALL REAL(KIND=JPRD),EXTERNAL :: TIMEF ! === END OF INTERFACE BLOCK === IF(PRESENT(PELAPSED_TIME).OR. PRESENT(PELAPSED_TIME_SINCE)) THEN ZWALL=TIMEF() ! TIMEF returns milliseconds since first call to TIMEF IF(PRESENT(PELAPSED_TIME)) THEN PELAPSED_TIME=ZWALL*1.0E-3_JPRD ENDIF IF(PRESENT(PELAPSED_TIME_SINCE)) THEN PELAPSED_TIME_SINCE=ZWALL*1.0E-3_JPRD - PELAPSED_TIME_SINCE ENDIF ENDIF IF( PRESENT(PVECTOR_CP) .OR. PRESENT(PTOTAL_CP) ) THEN CALL CPTIME(ZVECTOR_CP,ZTOTAL_CP) ENDIF IF( PRESENT(PVECTOR_CP) ) THEN PVECTOR_CP=ZVECTOR_CP ENDIF IF( PRESENT(PTOTAL_CP) ) THEN PTOTAL_CP=ZTOTAL_CP ENDIF RETURN END SUBROUTINE USER_CLOCK fiat-ecmwf-2.0.0/src/fiat/util/ec_args_mod.F900000664000175000017500000001057315157200431021134 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! module ec_args_mod !**** Interface to ec_args command-line handling ! ! Purpose. ! -------- ! Fortran 90 Interface to storing and retrieving command line arguments ! for the C ec_args API. ! ! An example C program: ! ! #include "ec_args.h" ! int main( int argc, char* argv[] ) { ! ec_args(argc,argv); ! int num_args = ec_argc(); ! const char* name = ec_argv()[0]; ! } ! ! An example Fortran program to do the same: ! ! program main ! use ec_args_mod ! integer :: num_args ! character(len=:), allocatable :: name ! call ec_args() ! num_args = ec_argc() ! name = ec_argv(0) ! end program ! ! Author. ! ------- ! W.Deconinck, ECMWF ! ! Modifications. ! -------------- ! Original: 2021-05-18 ! ! ------------------------------------------------------------------ implicit none private public :: ec_argc, ec_argv, ec_args #define MAX_ARG_LEN 1024 #define EC_MAX_ARGS 512 !! Matches value in ec_args.c interface function ec_argc() bind(C,name="ec_argc") result(argc) use, intrinsic :: iso_c_binding, only : c_int integer(c_int) :: argc end function function ec_argv_bindc() bind(C,name="ec_argv") result(argv) use, intrinsic :: iso_c_binding, only : c_ptr type(c_ptr) :: argv end function subroutine ec_args_bindc(argc,argv) BIND(C,NAME="ec_args") use, intrinsic :: iso_c_binding, only : c_int, c_ptr integer(c_int), value :: argc type(c_ptr), dimension(*) :: argv end subroutine end interface contains function ec_argv(iarg) result(argv) use, intrinsic :: iso_c_binding implicit none character(len=:), allocatable :: argv integer(c_int), intent(in) :: iarg integer(c_int) :: argc type(c_ptr) :: argv_cptr type(c_ptr), pointer :: argv_cptrs(:) argc = ec_argc() argv_cptr = ec_argv_bindc() call c_f_pointer ( argv_cptr , argv_cptrs, (/argc/) ) argv = to_string( argv_cptrs(iarg+1), MAX_ARG_LEN ) end function subroutine ec_args() use, intrinsic :: iso_c_binding implicit none integer(c_int) :: argc type(c_ptr) :: argv(EC_MAX_ARGS) if( ec_argc() == 0 ) then call read_command_line(argc,argv) call ec_args_bindc(argc,argv) endif end subroutine function to_string(cptr,maxlen) result(string) ! Convert string from C (char*) to Fortran ! (copied from fckit) use, intrinsic :: iso_c_binding implicit none character(len=:), allocatable :: string type(c_ptr) :: cptr integer(c_int) :: maxlen character(kind=c_char,len=1), pointer :: s(:) integer i, nchars call c_f_pointer ( cptr , s, (/maxlen/) ) i = 1 do if (s(i) == c_null_char) exit i = i + 1 enddo nchars = i - 1 ! Exclude null character from Fortran string allocate( character(len=(nchars)) :: string ) do i=1,nchars string(i:i) = s(i) enddo end function subroutine read_command_line(argc,argv) ! Read command line arguments into argc and argv as in C ! (copied from fckit) use, intrinsic :: iso_c_binding implicit none integer(c_int), parameter :: CMD_MAX_LEN = MAX_ARG_LEN * EC_MAX_ARGS integer(c_int) :: argc type(c_ptr) :: argv(:) character(kind=c_char,len=1), save, target :: args(CMD_MAX_LEN) character(kind=c_char,len=CMD_MAX_LEN), save, target :: cmd character(kind=c_char,len=CMD_MAX_LEN) :: arg integer(c_int) :: iarg, arglen, pos, ich, argpos call get_command(cmd) do ich=1,len(cmd) if (cmd(ich:ich) == " ") then cmd(ich:ich) = c_null_char exit endif enddo argv(1) = c_loc(cmd(1:1)) argc = command_argument_count()+1 pos = 1 do iarg=1,argc argpos = pos call get_command_argument(iarg, arg ) arglen = len_trim(arg) do ich=1,arglen args(pos) = arg(ich:ich) pos = pos+1 end do args(pos) = c_null_char; pos = pos+1 args(pos) = " "; pos = pos+1 argv(iarg+1) = c_loc(args(argpos)) enddo end subroutine end module fiat-ecmwf-2.0.0/src/fiat/util/ec_checksum.F900000664000175000017500000007005615157200431021145 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! module ec_checksum_mod !**** Checksum of arrays ! ! Purpose. ! -------- ! Take the checksum of an array printed as 4-char string ! ! An example Fortran programs: ! ! program main ! use ec_checksum_mod, only: fletcher16, fletcher16_hex ! write(0,*) fletcher16(array(:,:)) ! as integer ! write(0,*) fletcher16_hex(array(:,:)) ! as hex-string ! end program ! ! Multiple arrays can be checksummed together to a single hash: ! ! program main ! use ec_checksum_mod, only: fletcher16_type ! type(fletcher16_type) :: checksum ! call checksum%update(array1(:,:)) ! call checksum%update(array2(:,:,:)) ! write(0,*) checksum%digest_hex() ! end program ! ! Author. ! ------- ! W.Deconinck, ECMWF ! ! Modifications. ! -------------- ! Original: 2025-07-04 ! ! ------------------------------------------------------------------ use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int32_t, c_int16_t, c_char implicit none private public :: fletcher16_type, fletcher16, fletcher16_hex #define fletcher16_digest_t c_int16_t ! Workaround an internal compiler error in function digest() for NVHPC <= 22 and Classic Flang (PGI-based) #if defined(__NVCOMPILER) #if __NVCOMPILER_MAJOR__ <= 22 #undef fletcher16_digest_t #define fletcher16_digest_t c_int32_t #endif #elif defined(__FLANG) ! Classic Flang (PGI-based), includes also AOCC/4.0. Note, LLVM Flang defines __flang__ and __llvm__ instead. #undef fletcher16_digest_t #define fletcher16_digest_t c_int32_t #endif type :: fletcher16_type integer(c_int32_t) :: handle = 0 contains procedure, public :: reset => fletcher16_reset procedure, private :: update_real32_r1 => fletcher16_update_real32_r1 procedure, private :: update_real32_r2 => fletcher16_update_real32_r2 procedure, private :: update_real32_r3 => fletcher16_update_real32_r3 procedure, private :: update_real32_r4 => fletcher16_update_real32_r4 procedure, private :: update_real32_r5 => fletcher16_update_real32_r5 procedure, private :: update_real64_r1 => fletcher16_update_real64_r1 procedure, private :: update_real64_r2 => fletcher16_update_real64_r2 procedure, private :: update_real64_r3 => fletcher16_update_real64_r3 procedure, private :: update_real64_r4 => fletcher16_update_real64_r4 procedure, private :: update_real64_r5 => fletcher16_update_real64_r5 procedure, private :: update_int32_r1 => fletcher16_update_int32_r1 procedure, private :: update_int32_r2 => fletcher16_update_int32_r2 procedure, private :: update_int32_r3 => fletcher16_update_int32_r3 procedure, private :: update_int32_r4 => fletcher16_update_int32_r4 procedure, private :: update_int32_r5 => fletcher16_update_int32_r5 procedure, private :: update_int64_r1 => fletcher16_update_int64_r1 procedure, private :: update_int64_r2 => fletcher16_update_int64_r2 procedure, private :: update_int64_r3 => fletcher16_update_int64_r3 procedure, private :: update_int64_r4 => fletcher16_update_int64_r4 procedure, private :: update_int64_r5 => fletcher16_update_int64_r5 generic, public :: update => & & update_real32_r1, update_real32_r2, update_real32_r3, update_real32_r4, update_real32_r5, & & update_real64_r1, update_real64_r2, update_real64_r3, update_real64_r4, update_real64_r5, & & update_int32_r1, update_int32_r2, update_int32_r3, update_int32_r4, update_int32_r5, & & update_int64_r1, update_int64_r2, update_int64_r3, update_int64_r4, update_int64_r5 procedure, public :: digest => fletcher16__digest procedure, public :: digest_hex => fletcher16__digest_hex end type interface subroutine c_fletcher16_reset(checksum) bind(C,name="ec_checksum_fletcher16_reset") use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int32_t), intent(inout) :: checksum end subroutine subroutine c_ec_checksum_fletcher16_update(checksum, data, size) bind(C,name="ec_checksum_fletcher16_update") use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int32_t integer(c_int32_t), intent(inout) :: checksum type(c_ptr), value, intent(in) :: data integer(c_size_t), value, intent(in) :: size end subroutine function c_ec_checksum_fletcher16_digest(checksum) bind(C,name="ec_checksum_fletcher16_digest") result(digest) use, intrinsic :: iso_c_binding, only : c_int32_t, c_int16_t integer(c_int16_t) :: digest integer(c_int32_t), intent(in) :: checksum end function end interface interface fletcher16 module procedure fletcher16_real32_r1 module procedure fletcher16_real32_r2 module procedure fletcher16_real32_r3 module procedure fletcher16_real32_r4 module procedure fletcher16_real32_r5 module procedure fletcher16_real64_r1 module procedure fletcher16_real64_r2 module procedure fletcher16_real64_r3 module procedure fletcher16_real64_r4 module procedure fletcher16_real64_r5 module procedure fletcher16_int32_r1 module procedure fletcher16_int32_r2 module procedure fletcher16_int32_r3 module procedure fletcher16_int32_r4 module procedure fletcher16_int32_r5 module procedure fletcher16_int64_r1 module procedure fletcher16_int64_r2 module procedure fletcher16_int64_r3 module procedure fletcher16_int64_r4 module procedure fletcher16_int64_r5 end interface interface fletcher16_hex module procedure fletcher16_hex_real32_r1 module procedure fletcher16_hex_real32_r2 module procedure fletcher16_hex_real32_r3 module procedure fletcher16_hex_real32_r4 module procedure fletcher16_hex_real32_r5 module procedure fletcher16_hex_real64_r1 module procedure fletcher16_hex_real64_r2 module procedure fletcher16_hex_real64_r3 module procedure fletcher16_hex_real64_r4 module procedure fletcher16_hex_real64_r5 module procedure fletcher16_hex_int32_r1 module procedure fletcher16_hex_int32_r2 module procedure fletcher16_hex_int32_r3 module procedure fletcher16_hex_int32_r4 module procedure fletcher16_hex_int32_r5 module procedure fletcher16_hex_int64_r1 module procedure fletcher16_hex_int64_r2 module procedure fletcher16_hex_int64_r3 module procedure fletcher16_hex_int64_r4 module procedure fletcher16_hex_int64_r5 end interface interface to_hex module procedure to_hex_16 module procedure to_hex_32 module procedure to_hex_64 end interface contains subroutine to_lower_inplace(string) character(len=*), intent(inout) :: string integer :: i do i = 1, len(string) string(i:i) = char_to_lower(string(i:i)) end do contains pure function char_to_lower(c) result(t) character(len=1), intent(in) :: c !! A character. character(len=1) :: t integer, parameter :: wp= iachar('a')-iachar('A'), BA=iachar('A'), BZ=iachar('Z') integer :: k ! Check whether the integer equivalent is between BA=65 and BZ=90 k = ichar(c) if (k>=BA.and.k<=BZ) k = k + wp t = char(k) end function end subroutine function to_hex_16(value) result(hex) use, intrinsic :: iso_c_binding, only : c_int16_t character(len=4) :: hex integer(c_int16_t), intent(in) :: value write(hex,'(z4.4)') value call to_lower_inplace(hex) end function function to_hex_32(value) result(hex) use, intrinsic :: iso_c_binding, only : c_int32_t character(len=8) :: hex integer(c_int32_t), intent(in) :: value write(hex,'(z8.8)') value call to_lower_inplace(hex) end function function to_hex_64(value) result(hex) use, intrinsic :: iso_c_binding, only : c_int64_t character(len=16) :: hex integer(c_int64_t), intent(in) :: value write(hex,'(z16.16)') value call to_lower_inplace(hex) end function subroutine fletcher16_reset(this) class(fletcher16_type), intent(inout) :: this this%handle = 0 end subroutine subroutine fletcher16_update_real32_r1(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_float class(fletcher16_type), intent(inout) :: this real(c_float), contiguous, target, intent(in) :: array(:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1)), c_sizeof(array(1)) * array_size) endif end subroutine subroutine fletcher16_update_real32_r2(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_float class(fletcher16_type), intent(inout) :: this real(c_float), contiguous, target, intent(in) :: array(:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1)), c_sizeof(array(1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real32_r3(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_float class(fletcher16_type), intent(inout) :: this real(c_float), contiguous, target, intent(in) :: array(:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1)), c_sizeof(array(1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real32_r4(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_float class(fletcher16_type), intent(inout) :: this real(c_float), contiguous, target, intent(in) :: array(:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1)), c_sizeof(array(1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real32_r5(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_float class(fletcher16_type), intent(inout) :: this real(c_float), contiguous, target, intent(in) :: array(:,:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1,1)), c_sizeof(array(1,1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real64_r1(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_double class(fletcher16_type), intent(inout) :: this real(c_double), contiguous, target, intent(in) :: array(:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1)), c_sizeof(array(1)) * array_size) endif end subroutine subroutine fletcher16_update_real64_r2(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_double class(fletcher16_type), intent(inout) :: this real(c_double), contiguous, target, intent(in) :: array(:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1)), c_sizeof(array(1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real64_r3(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_double class(fletcher16_type), intent(inout) :: this real(c_double), contiguous, target, intent(in) :: array(:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1)), c_sizeof(array(1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real64_r4(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_double class(fletcher16_type), intent(inout) :: this real(c_double), contiguous, target, intent(in) :: array(:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1)), c_sizeof(array(1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_real64_r5(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_double class(fletcher16_type), intent(inout) :: this real(c_double), contiguous, target, intent(in) :: array(:,:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1,1)), c_sizeof(array(1,1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int32_r1(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_int32_t class(fletcher16_type), intent(inout) :: this integer(c_int32_t), contiguous, target, intent(in) :: array(:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1)), c_sizeof(array(1)) * array_size) endif end subroutine subroutine fletcher16_update_int32_r2(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_int32_t class(fletcher16_type), intent(inout) :: this integer(c_int32_t), contiguous, target, intent(in) :: array(:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1)), c_sizeof(array(1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int32_r3(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_int32_t class(fletcher16_type), intent(inout) :: this integer(c_int32_t), contiguous, target, intent(in) :: array(:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1)), c_sizeof(array(1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int32_r4(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_int32_t class(fletcher16_type), intent(inout) :: this integer(c_int32_t), contiguous, target, intent(in) :: array(:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1)), c_sizeof(array(1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int32_r5(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_loc, c_sizeof, c_int32_t class(fletcher16_type), intent(inout) :: this integer(c_int32_t), contiguous, target, intent(in) :: array(:,:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1,1)), c_sizeof(array(1,1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int64_r1(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int64_t, c_loc, c_sizeof class(fletcher16_type), intent(inout) :: this integer(c_int64_t), contiguous, target, intent(in) :: array(:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1)), c_sizeof(array(1)) * array_size) endif end subroutine subroutine fletcher16_update_int64_r2(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int64_t, c_loc, c_sizeof class(fletcher16_type), intent(inout) :: this integer(c_int64_t), contiguous, target, intent(in) :: array(:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1)), c_sizeof(array(1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int64_r3(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int64_t, c_loc, c_sizeof class(fletcher16_type), intent(inout) :: this integer(c_int64_t), contiguous, target, intent(in) :: array(:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1)), c_sizeof(array(1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int64_r4(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int64_t, c_loc, c_sizeof class(fletcher16_type), intent(inout) :: this integer(c_int64_t), contiguous, target, intent(in) :: array(:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1)), c_sizeof(array(1,1,1,1)) * array_size) endif end subroutine subroutine fletcher16_update_int64_r5(this, array) use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int64_t, c_loc, c_sizeof class(fletcher16_type), intent(inout) :: this integer(c_int64_t), contiguous, target, intent(in) :: array(:,:,:,:,:) integer(c_size_t) :: array_size array_size = size(array,kind=c_size_t) if (array_size > 0) then call c_ec_checksum_fletcher16_update(this%handle, c_loc(array(1,1,1,1,1)), c_sizeof(array(1,1,1,1,1)) * array_size) endif end subroutine function fletcher16__digest(this) result(digest) class(fletcher16_type), intent(in) :: this integer(fletcher16_digest_t) :: digest digest = c_ec_checksum_fletcher16_digest(this%handle) end function function fletcher16__digest_hex(this) result(digest) class(fletcher16_type), intent(in) :: this character(len=4) :: digest digest = to_hex_16(int(this%digest(),c_int16_t)) end function function fletcher16_real32_r1(array) result(digest) use, intrinsic :: iso_c_binding, only : c_float integer(c_int16_t) :: digest real(c_float), intent(in) :: array(:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real32_r2(array) result(digest) use, intrinsic :: iso_c_binding, only : c_float integer(c_int16_t) :: digest real(c_float), intent(in) :: array(:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real32_r3(array) result(digest) use, intrinsic :: iso_c_binding, only : c_float integer(c_int16_t) :: digest real(c_float), intent(in) :: array(:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real32_r4(array) result(digest) use, intrinsic :: iso_c_binding, only : c_float integer(c_int16_t) :: digest real(c_float), intent(in) :: array(:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real32_r5(array) result(digest) use, intrinsic :: iso_c_binding, only : c_float integer(c_int16_t) :: digest real(c_float), intent(in) :: array(:,:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real64_r1(array) result(digest) use, intrinsic :: iso_c_binding, only : c_double integer(c_int16_t) :: digest real(c_double), intent(in) :: array(:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real64_r2(array) result(digest) use, intrinsic :: iso_c_binding, only : c_double integer(c_int16_t) :: digest real(c_double), intent(in) :: array(:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real64_r3(array) result(digest) use, intrinsic :: iso_c_binding, only : c_double integer(c_int16_t) :: digest real(c_double), intent(in) :: array(:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real64_r4(array) result(digest) use, intrinsic :: iso_c_binding, only : c_double integer(c_int16_t) :: digest real(c_double), intent(in) :: array(:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_real64_r5(array) result(digest) use, intrinsic :: iso_c_binding, only : c_double integer(c_int16_t) :: digest real(c_double), intent(in) :: array(:,:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int32_r1(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int16_t) :: digest integer(c_int32_t), intent(in) :: array(:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int32_r2(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int16_t) :: digest integer(c_int32_t), intent(in) :: array(:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int32_r3(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int16_t) :: digest integer(c_int32_t), intent(in) :: array(:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int32_r4(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int16_t) :: digest integer(c_int32_t), intent(in) :: array(:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int32_r5(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int32_t integer(c_int16_t) :: digest integer(c_int32_t), intent(in) :: array(:,:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int64_r1(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int64_t integer(c_int16_t) :: digest integer(c_int64_t), intent(in) :: array(:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int64_r2(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int64_t integer(c_int16_t) :: digest integer(c_int64_t), intent(in) :: array(:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int64_r3(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int64_t integer(c_int16_t) :: digest integer(c_int64_t), intent(in) :: array(:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int64_r4(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int64_t integer(c_int16_t) :: digest integer(c_int64_t), intent(in) :: array(:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_int64_r5(array) result(digest) use, intrinsic :: iso_c_binding, only : c_int64_t integer(c_int16_t) :: digest integer(c_int64_t), intent(in) :: array(:,:,:,:,:) type(fletcher16_type) :: checksum call checksum%update(array) digest = checksum%digest() end function function fletcher16_hex_real32_r1(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_float character(len=4) :: hex4 real(c_float), intent(in) :: array(:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real32_r2(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_float character(len=4) :: hex4 real(c_float), intent(in) :: array(:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real32_r3(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_float character(len=4) :: hex4 real(c_float), intent(in) :: array(:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real32_r4(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_float character(len=4) :: hex4 real(c_float), intent(in) :: array(:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real32_r5(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_float character(len=4) :: hex4 real(c_float), intent(in) :: array(:,:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real64_r1(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_double character(len=4) :: hex4 real(c_double), intent(in) :: array(:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real64_r2(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_double character(len=4) :: hex4 real(c_double), intent(in) :: array(:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real64_r3(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_double character(len=4) :: hex4 real(c_double), intent(in) :: array(:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real64_r4(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_double character(len=4) :: hex4 real(c_double), intent(in) :: array(:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_real64_r5(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_double character(len=4) :: hex4 real(c_double), intent(in) :: array(:,:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int32_r1(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int32_t character(len=4) :: hex4 integer(c_int32_t), intent(in) :: array(:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int32_r2(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int32_t character(len=4) :: hex4 integer(c_int32_t), intent(in) :: array(:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int32_r3(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int32_t character(len=4) :: hex4 integer(c_int32_t), intent(in) :: array(:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int32_r4(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int32_t character(len=4) :: hex4 integer(c_int32_t), intent(in) :: array(:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int32_r5(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int32_t character(len=4) :: hex4 integer(c_int32_t), intent(in) :: array(:,:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int64_r1(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int64_t character(len=4) :: hex4 integer(c_int64_t), intent(in) :: array(:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int64_r2(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int64_t character(len=4) :: hex4 integer(c_int64_t), intent(in) :: array(:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int64_r3(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int64_t character(len=4) :: hex4 integer(c_int64_t), intent(in) :: array(:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int64_r4(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int64_t character(len=4) :: hex4 integer(c_int64_t), intent(in) :: array(:,:,:,:) hex4 = to_hex(fletcher16(array)) end function function fletcher16_hex_int64_r5(array) result(hex4) use, intrinsic :: iso_c_binding, only : c_int64_t character(len=4) :: hex4 integer(c_int64_t), intent(in) :: array(:,:,:,:,:) hex4 = to_hex(fletcher16(array)) end function end module fiat-ecmwf-2.0.0/src/fiat/util/strhandler_mod.F900000664000175000017500000001305315157200431021673 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! !OPTIONS NOOPT MODULE STRHANDLER_MOD USE EC_PARKIND ,ONLY : JPIM, JPRM, JPRD IMPLICIT NONE PRIVATE PUBLIC :: TOLOWER, TOUPPER, EXPAND_STRING PUBLIC :: SADJUSTL, SADJUSTR PUBLIC :: STRANSFER INTERFACE STRANSFER MODULE PROCEDURE & STRANSFER_R8_TO_STR, STRANSFER_STR_TO_R8, & & STRANSFER_R4_TO_STR, STRANSFER_STR_TO_R4 END INTERFACE CONTAINS FUNCTION STRANSFER_R8_TO_STR(SOURCE, MOLD) RESULT(C) REAL(KIND=JPRD) , INTENT(IN) :: SOURCE CHARACTER(LEN=*), INTENT(IN) :: MOLD CHARACTER(LEN=8) :: C CALL ECMWF_TRANSFER(C,MIN(8,LEN(MOLD)),SOURCE,8) END FUNCTION STRANSFER_R8_TO_STR FUNCTION STRANSFER_STR_TO_R8(SOURCE, MOLD) RESULT(Z) CHARACTER(LEN=*), INTENT(IN) :: SOURCE REAL(KIND=JPRD) , INTENT(IN) :: MOLD REAL(KIND=JPRD) :: Z CALL ECMWF_TRANSFER(Z,8,SOURCE,LEN(SOURCE)) END FUNCTION STRANSFER_STR_TO_R8 FUNCTION STRANSFER_R4_TO_STR(SOURCE, MOLD) RESULT(C) REAL(KIND=JPRM) , INTENT(IN) :: SOURCE CHARACTER(LEN=*), INTENT(IN) :: MOLD CHARACTER(LEN=4) :: C CALL ECMWF_TRANSFER(C,MIN(4,LEN(MOLD)),SOURCE,4) END FUNCTION STRANSFER_R4_TO_STR FUNCTION STRANSFER_STR_TO_R4(SOURCE, MOLD) RESULT(Z) CHARACTER(LEN=*), INTENT(IN) :: SOURCE REAL(KIND=JPRM) , INTENT(IN) :: MOLD REAL(KIND=JPRM) :: Z CALL ECMWF_TRANSFER(Z,4,SOURCE,LEN(SOURCE)) END FUNCTION STRANSFER_STR_TO_R4 FUNCTION SADJUSTL(S) RESULT(C) CHARACTER(LEN=*), INTENT(IN) :: S CHARACTER(LEN=MAX(1,LEN(S))) C C = ' ' IF (LEN(S) > 0) THEN IF (S /= ' ') C = ADJUSTL(S) ENDIF END FUNCTION SADJUSTL FUNCTION SADJUSTR(S) RESULT(C) CHARACTER(LEN=*), INTENT(IN) :: S CHARACTER(LEN=MAX(1,LEN(S))) C C = ' ' IF (LEN(S) > 0) THEN IF (S /= ' ') C = ADJUSTR(S) ENDIF END FUNCTION SADJUSTR SUBROUTINE TOLOWER(CDS) CHARACTER(LEN=*), INTENT(INOUT) :: CDS INTEGER(KIND=JPIM), PARAMETER :: ICH_A = ICHAR('a') INTEGER(KIND=JPIM), PARAMETER :: ICHA = ICHAR('A') INTEGER(KIND=JPIM), PARAMETER :: ICHZ = ICHAR('Z') INTEGER(KIND=JPIM) :: I, ICH, NEW_ICH CHARACTER(LEN=1) CH DO I=1,LEN(CDS) CH = CDS(I:I) ICH = ICHAR(CH) IF ( ICH >= ICHA .AND. ICH <= ICHZ ) THEN NEW_ICH = ICH + (ICH_A - ICHA) CH = CHAR(NEW_ICH) CDS(I:I) = CH ENDIF ENDDO END SUBROUTINE TOLOWER SUBROUTINE TOUPPER(CDS) CHARACTER(LEN=*), INTENT(INOUT) :: CDS INTEGER(KIND=JPIM), PARAMETER :: ICH_A = ICHAR('A') INTEGER(KIND=JPIM), PARAMETER :: ICHA = ICHAR('a') INTEGER(KIND=JPIM), PARAMETER :: ICHZ = ICHAR('z') INTEGER(KIND=JPIM) :: I, ICH, NEW_ICH CHARACTER(LEN=1) CH DO I=1,LEN(CDS) CH = CDS(I:I) ICH = ICHAR(CH) IF ( ICH >= ICHA .AND. ICH <= ICHZ ) THEN NEW_ICH = ICH + (ICH_A - ICHA) CH = CHAR(NEW_ICH) CDS(I:I) = CH ENDIF ENDDO END SUBROUTINE TOUPPER SUBROUTINE EXPAND_STRING(& &MYPROC, &! %p &nproc, &! %n ×tep, &! %t &max_timestep,& &s) ! %s INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC, NPROC INTEGER(KIND=JPIM), INTENT(IN) :: TIMESTEP, MAX_TIMESTEP CHARACTER(LEN=*), INTENT(INOUT) :: S(:) CHARACTER(LEN=2*LEN(S)) T CHARACTER(LEN=2*LEN(S)) TT INTEGER(KIND=JPIM) :: I, J, JJ, LOC_P, LEN_T, N INTEGER(KIND=JPIM) :: NDIGS(4), NUM(4) CHARACTER(LEN=6) FMT(4) N = SIZE(S) IF (N < 1) RETURN !* Setup output formats NUM(1) = MYPROC NUM(2) = MAX(NPROC,MYPROC) NUM(3) = N NUM(4) = MAX(MAX_TIMESTEP,TIMESTEP) !* Count number of digits in each integer DO J=1,4 NDIGS(J) = 1 IF (NUM(J) /= 0) THEN NDIGS(J) = 1 + LOG10(DBLE(ABS(NUM(J)))) IF (NUM(J) < 0) NDIGS(J) = NDIGS(J) + 1 ! Room for minus sign ENDIF NDIGS(J) = MIN(NDIGS(J),9) ! Max 9 digits supported; i.e. '999999999' WRITE(FMT(J),'("(i",i1,")")') NDIGS(J) ENDDO !* Expand fields '%s', '%p', '%n' and '%t' with their values !* A special treatment with the sequence numbering IF (N>1) THEN LOC_P = INDEX(S(1),'%s') IF (LOC_P > 0) THEN S(2:) = S(1) ENDIF ENDIF DO I=1,N T = ADJUSTL(S(I))//' ' LOC_P = INDEX(T,'%') IF (LOC_P > 0) THEN LEN_T = LEN_TRIM(T) J = LOC_P TT(:J-1) = T(:J-1) TT(J:) = ' ' JJ = J-1 DO WHILE (J <= LEN_T) IF (T(J:J) == '%') THEN J = J + 1 IF (J <= LEN_T) THEN SELECT CASE ( T(J:J) ) CASE ( 'p' ) ! myproc WRITE(TT(JJ+1:JJ+NDIGS(1)),FMT(1)) MYPROC JJ = JJ + NDIGS(1) CASE ( 'n' ) ! nproc WRITE(TT(JJ+1:JJ+NDIGS(2)),FMT(2)) NPROC JJ = JJ + NDIGS(2) CASE ( 's' ) ! sequence number i=[1..n] WRITE(TT(JJ+1:JJ+NDIGS(3)),FMT(3)) I JJ = JJ + NDIGS(3) CASE ( 't' ) ! timestep WRITE(TT(JJ+1:JJ+NDIGS(4)),FMT(4)) TIMESTEP JJ = JJ + NDIGS(4) CASE DEFAULT TT(JJ+1:JJ+2) = '%'//T(J:J) JJ = JJ + 2 END SELECT ELSE TT(JJ+1:JJ+1) = '%' JJ = JJ + 1 ENDIF ELSE TT(JJ+1:JJ+1) = T(J:J) JJ = JJ + 1 ENDIF J = J + 1 ENDDO T = ADJUSTL(TT) !* Get also rid of any blanks in the middle of the string LEN_T = LEN_TRIM(T) J = 1 DO WHILE (J < LEN_T) IF (T(J:J) == ' ') THEN T(J:) = T(J+1:) LEN_T = LEN_TRIM(T) ELSE J = J + 1 ENDIF ENDDO ENDIF S(I) = T ENDDO END SUBROUTINE EXPAND_STRING END MODULE STRHANDLER_MOD fiat-ecmwf-2.0.0/src/fiat/util/ec_exit.c0000664000175000017500000000112415157200431020166 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ec_exit.c */ #include #include /* CALL ec_exit(iexit_code) */ void ec_exit_(const int *exit_code) { exit(exit_code ? *exit_code : 0); } fiat-ecmwf-2.0.0/src/fiat/util/meminfo.F900000664000175000017500000000150615157200431020320 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE MEMINFO(KOUT,KSTEP) USE EC_PARKIND, ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KOUT, KSTEP CHARACTER(LEN=32) CLSTEP INTEGER(KIND=JPIM) :: ICOMM #include "ec_meminfo.intfb.h" WRITE(CLSTEP,'(11X,"STEP",I5," :")') KSTEP ICOMM = -2 ! No headers from EC_MEMINFO by default IF (KSTEP == 0) ICOMM = -1 ! Print also headers CALL EC_MEMINFO(KOUT,TRIM(CLSTEP),ICOMM,KBARR=0,KIOTASK=-1,KCALL=-1) CALL EC_FLUSH(KOUT) END SUBROUTINE MEMINFO fiat-ecmwf-2.0.0/src/fiat/util/namelist_mod.F900000664000175000017500000002012315157200431021335 0ustar alastairalastairMODULE NAMELIST_MOD ! This module contains namelist utilities, especially subroutines/function to ! position on the requested namelist "block" to read variables. ! ! To the legacy POSNAM and POSNAME subroutines from IAL (IFS-ARPEGE-LAM), ! a POSNAMEF function is added to enable a shorter syntax: ! IF (POSNAMEF(KULNAM, CDNAML, ...) == 0) READ(KULNAM, NAML) IMPLICIT NONE PUBLIC :: POSNAME, POSNAM, POSNAMEF CONTAINS ! ------------------------------------------------------------------ SUBROUTINE POSNAME(KULNAM,CDNAML,KSTAT,LDNOREWIND) !**** *POSNAME* - position namelist file for reading; return error code ! if namelist is not found ! Purpose. ! -------- ! To position namelist file at correct place for reading ! namelist CDNAML. Replaces use of Cray specific ability ! to skip to the correct namelist. !** Interface. ! ---------- ! *CALL* *POSNAME*(..) ! Explicit arguments : KULNAM - file unit number (input) ! -------------------- CDNAML - namelist name (input) ! KSTAT - non-zero if namelist not found ! 1 = namelist not found ! Author. ! ------- ! P.Marguinaud 22-Nov-2010 ! Modifications. ! -------------- ! R.Hogan 20-Jan-2022 Added no-rewind optional argument ! -------------------------------------------------------------- USE EC_PARKIND ,ONLY : JPIM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KULNAM CHARACTER(LEN=*) ,INTENT(IN) :: CDNAML INTEGER(KIND=JPIM),INTENT(OUT) :: KSTAT LOGICAL,OPTIONAL, INTENT(IN) :: LDNOREWIND #include "abor1.intfb.h" CHARACTER (LEN = 40) :: CLINE CHARACTER (LEN = 1) :: CLTEST INTEGER(KIND=JPIM) :: ILEN, IND1, ISTATUS, ISCAN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ----------------------------------------------------------- !* 1. POSITION FILE ! ------------- IF (LHOOK) CALL DR_HOOK('POSNAME',0,ZHOOK_HANDLE) KSTAT = 0 CLINE=' ' ! Rewind by default, but not if LDNOREWIND is present and TRUE. This ! is useful for reading an array of structures of arbitrary length ! from a namelist, by repeated use of the same group name. IF (.NOT. PRESENT(LDNOREWIND)) THEN REWIND(KULNAM) ELSEIF (.NOT. LDNOREWIND) THEN REWIND(KULNAM) ENDIF ILEN=LEN(CDNAML) ISTATUS=0 ISCAN=0 DO WHILE (ISTATUS==0 .AND. ISCAN==0) READ(KULNAM,'(A)',IOSTAT=ISTATUS) CLINE SELECT CASE (ISTATUS) CASE (:-1) KSTAT=1 ISCAN=-1 CASE (0) IF (INDEX(CLINE(1:10),'&') == 0) THEN ISCAN=0 ELSE IND1=INDEX(CLINE,'&'//CDNAML) IF (IND1 == 0) THEN ISCAN=0 ELSE CLTEST=CLINE(IND1+ILEN+1:IND1+ILEN+1) IF ( (LGE(CLTEST,'0').AND.LLE(CLTEST,'9')) & & .OR.(LGE(CLTEST,'A').AND.LLE(CLTEST,'Z')) ) THEN ISCAN=0 ELSE ISCAN=1 ENDIF ENDIF ENDIF CASE (1:) CALL ABOR1 ('POSNAME: AN ERROR OCCURRED WHILE READING THE NAMELIST') END SELECT ENDDO BACKSPACE(KULNAM) ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('POSNAME',1,ZHOOK_HANDLE) END SUBROUTINE POSNAME FUNCTION POSNAMEF(KULNAM, CDNAML, LDNOREWIND, LDFATAL, LDVERBOSE, KULOUT) RESULT(ISTAT) !**** *POSNAMEF* - function to position namelist file for reading and return error code ! if namelist is not found ! Purpose. ! -------- ! To position namelist file at correct place for reading namelist CDNAML. !** Interface. ! ---------- ! IF (POSNAMEF(KULNAM, CDNAML, ...) == 0) READ(KULNAM, NAML) ! Explicit arguments : KULNAM - file unit number (input) ! -------------------- CDNAML - namelist name (input) ! LDNOREWIND - no rewind; This is useful for ! reading an array of structures of arbitrary ! length from a namelist, by repeated use of ! the same group name. ! LDFATAL - to call ABOR1 in case CDNAML not present in file ! The default value is .TRUE. or can be defined via env var ! POSNAMEF_DEFAULT_FATAL=0 ! LDVERBOSE - verbosity ! KULOUT - output unit for verbosity USE EC_PARKIND, ONLY : JPIM USE EC_LUN, ONLY : NULOUT USE YOMHOOK, ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KULNAM CHARACTER(LEN=*), INTENT(IN) :: CDNAML LOGICAL,OPTIONAL, INTENT(IN) :: LDNOREWIND LOGICAL,OPTIONAL, INTENT(IN) :: LDFATAL LOGICAL,OPTIONAL, INTENT(IN) :: LDVERBOSE INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KULOUT INTEGER(KIND=JPIM) :: ISTAT CHARACTER(LEN=256) :: CLFILE LOGICAL :: LLNOREWIND LOGICAL :: LLFATAL CHARACTER(LEN=256) :: CLFATAL LOGICAL :: LLVERBOSE INTEGER :: ILULOUT REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #include "abor1.intfb.h" IF (LHOOK) CALL DR_HOOK('POSNAMEF',0,ZHOOK_HANDLE) ! defaults LLNOREWIND = .FALSE. CALL GET_ENVIRONMENT_VARIABLE('POSNAMEF_DEFAULT_FATAL',CLFATAL) IF (TRIM(CLFATAL) == '' .OR. TRIM(CLFATAL) == '1') THEN LLFATAL = .TRUE. ELSE LLFATAL = .FALSE. ENDIF LLVERBOSE = .TRUE. ILULOUT = NULOUT ! optional arguments IF (PRESENT(LDNOREWIND)) LLNOREWIND = LDNOREWIND IF (PRESENT(LDFATAL)) LLFATAL = LDFATAL IF (PRESENT(LDVERBOSE)) LLVERBOSE = LDVERBOSE IF (PRESENT(KULOUT)) ILULOUT = KULOUT CLFILE="" INQUIRE(KULNAM,NAME=CLFILE) IF (CLFILE == "") THEN ! No file is explicitely connected to this logical unit number yet ! (because the file is not yet opened) ! then give it its standard name "fort.KULNAM" : IF (KULNAM <= 9) THEN WRITE(CLFILE,'(''fort.'',I1)') KULNAM ELSE WRITE(CLFILE,'(''fort.'',I2)') KULNAM ENDIF ENDIF IF (LLVERBOSE) WRITE(ILULOUT,"('Reading namelist ',A,' from ',A)") CDNAML,TRIM(CLFILE) CALL POSNAME (KULNAM, CDNAML, ISTAT, LDNOREWIND=LLNOREWIND) SELECT CASE (ISTAT) CASE (0) CASE (1) IF (LLFATAL) THEN CALL ABOR1 ('POSNAM:CANNOT LOCATE '//CDNAML//' ') ENDIF CASE DEFAULT CALL ABOR1 ('POSNAM:READ ERROR IN NAMELIST FILE') END SELECT IF (LHOOK) CALL DR_HOOK('POSNAMEF',1,ZHOOK_HANDLE) END FUNCTION POSNAMEF SUBROUTINE POSNAM(KULNAM, CDNAML) !**** *POSNAM* - position namelist file for reading ! Purpose. ! -------- ! To position namelist file at correct place for reading ! namelist CDNAML. Replaces use of Cray specific ability ! to skip to the correct namelist. !** Interface. ! ---------- ! *CALL* *POSNAM*(..) ! Explicit arguments : KULNAM - file unit number (input) ! -------------------- CDNAML - namelist name (input) ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! See documentation ! Externals. None ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 93-06-22 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! M.Hamrud 01-Dec-2003 CY28R1 Cleaning ! R. El Khatib 04-08-10 Apply norms + proper abort if namelist is missing ! P. Marguinaud Proxy to POSNAME ! H Petithomme Sept 2023: some cleaning ! R. El Khatib 11-Feb-2025 Fix uninitialized filename and arbitrary choice "fort.4" ! A.Mary 22-05-2025: move contents to POSNAMEF ! -------------------------------------------------------------- USE EC_PARKIND, ONLY : JPIM USE YOMHOOK, ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KULNAM CHARACTER(LEN=*) ,INTENT(IN) :: CDNAML INTEGER(KIND=JPIM) :: ISTAT REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('POSNAM',0,ZHOOK_HANDLE) ISTAT = POSNAMEF(KULNAM, CDNAML, & & LDNOREWIND=.FALSE., & & LDFATAL=.TRUE., & & LDVERBOSE=.TRUE.) IF (LHOOK) CALL DR_HOOK('POSNAM',1,ZHOOK_HANDLE) END SUBROUTINE POSNAM END MODULE NAMELIST_MOD fiat-ecmwf-2.0.0/src/fiat/util/byteswap_mod.F900000664000175000017500000001325315157200431021365 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE BYTESWAP_MOD !**** Module for byteswapping buffers ! Purpose. ! -------- ! Fortran 90 Interface to calling byteswap ! Author. ! ------- ! W.Deconinck ECMWF ! Modifications. ! -------------- ! Original: 2025-01-30 ! ------------------------------------------------------------------ IMPLICIT NONE PRIVATE PUBLIC :: convert_to_big_endian, is_little_endian, byteswap ! ISO-C-BINDING C-interfaces INTERFACE ! void iswap_ (char * a, const char * b, const int * _t, const int * _n); subroutine iswap_bind( & & ptr_out, & & ptr_in, & & size_of_type_in_bytes, & & length) & & bind(c, name="iswap_") use, intrinsic :: iso_c_binding type(c_ptr), value, intent(in) :: ptr_out type(c_ptr), value, intent(in) :: ptr_in integer(c_int), intent(in) :: size_of_type_in_bytes integer(c_int), intent(in) :: length end subroutine ! void jswap_ (char * a, const char * b, const int * _t, const int * _n); subroutine jswap_bind( & & ptr_out, & & ptr_in, & & size_of_type_in_bytes, & & length) & & bind(c, name="jswap_") use, intrinsic :: iso_c_binding type(c_ptr), value, intent(in) :: ptr_out type(c_ptr), value, intent(in) :: ptr_in integer(c_int), intent(in) :: size_of_type_in_bytes integer(c_int), intent(in) :: length end subroutine ! void iswap_isle_ (int * reqd); subroutine iswap_isle_bind(value) bind(c,name="iswap_isle_") use, intrinsic :: iso_c_binding, only : c_int integer(c_int), intent(out) :: value end subroutine END INTERFACE INTERFACE convert_to_big_endian MODULE PROCEDURE convert_to_big_endian_int32_r1 MODULE PROCEDURE convert_to_big_endian_int64_r1 MODULE PROCEDURE convert_to_big_endian_real32_r1 MODULE PROCEDURE convert_to_big_endian_real64_r1 END INTERFACE INTERFACE byteswap MODULE PROCEDURE byteswap_int32_r1 MODULE PROCEDURE byteswap_int64_r1 MODULE PROCEDURE byteswap_real32_r1 MODULE PROCEDURE byteswap_real64_r1 END INTERFACE CONTAINS function is_little_endian() use, intrinsic :: iso_c_binding, only : c_int logical :: is_little_endian integer(c_int) :: isle call iswap_isle_bind(isle) if (isle == 0) then is_little_endian = .false. else is_little_endian = .true. endif end function subroutine convert_to_big_endian_int32_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int integer(c_int), target, intent(inout) :: array_out(:) integer(c_int), target, intent(in) :: array_in(:) call iswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine convert_to_big_endian_int64_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int, c_long integer(c_long), target, intent(inout) :: array_out(:) integer(c_long), target, intent(in) :: array_in(:) call iswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine convert_to_big_endian_real32_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int, c_float real(c_float), target, intent(inout) :: array_out(:) real(c_float), target, intent(in) :: array_in(:) call iswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine convert_to_big_endian_real64_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int, c_double real(c_double), target, intent(inout) :: array_out(:) real(c_double), target, intent(in) :: array_in(:) call iswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine byteswap_int32_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int integer(c_int), target, intent(inout) :: array_out(:) integer(c_int), target, intent(in) :: array_in(:) call jswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine byteswap_int64_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int, c_long integer(c_long), target, intent(inout) :: array_out(:) integer(c_long), target, intent(in) :: array_in(:) call jswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine byteswap_real32_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int, c_float real(c_float), target, intent(inout) :: array_out(:) real(c_float), target, intent(in) :: array_in(:) call jswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine subroutine byteswap_real64_r1( array_out, array_in ) use, intrinsic :: iso_c_binding, only : c_ptr, c_loc, c_sizeof, c_int, c_double real(c_double), target, intent(inout) :: array_out(:) real(c_double), target, intent(in) :: array_in(:) call jswap_bind(c_loc(array_out(1)), c_loc(array_in(1)), int(c_sizeof(array_in(1)),c_int), size(array_in)) end subroutine END MODULE fiat-ecmwf-2.0.0/src/fiat/util/ec_meminfo.F900000664000175000017500000010156315157200431020773 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE EC_MEMINFO(KU,CDSTRING,KCOMM,KBARR,KIOTASK,KCALL) USE EC_PARKIND, ONLY : JPIM, JPIB, JPRD USE MPL_MPI USE EC_ARGS_MOD, ONLY : EC_ARGV IMPLICIT NONE !-- EC_MEMINFO: ! Author : Peter Towers (ECMWF) : 2015-2016 ! Modified : Sami Saarinen (ECMWF) : 21-SEP-2016 : Added getenv EC_MEMINFO -- export EC_MEMINFO=0 disables any EC_MEMINFO output ! Sami Saarinen (ECMWF) : 02-MAR-2017 : Enabled flexible number of sockets & lots of tidying ! Sami Saarinen (ECMWF) : 09-MAR-2017 : Power monitoring added (via EC_PMON) -- works at least on Cray systems ! Sami Saarinen (ECMWF) : 12-MAR-2017 : Gather core affinities via call to ec_coreid() ! Sami Saarinen (ECMWF) : 12-DEC-2017 : Obtain MPI & OpenMP version information ! Sami Saarinen (HPCK) : 21-FEB-2022 : Cleaned up for FIAT (the Fortran IFS and Arpege Toolkit) #include "ec_pmon.intfb.h" INTEGER(KIND=JPIM), INTENT(IN) :: KU,KCOMM,KBARR,KIOTASK,KCALL CHARACTER(LEN=*), INTENT(IN) :: CDSTRING INTEGER(KIND=JPIM), PARAMETER :: ITAG = 32099 ! A prime number below 2^15 = 32768 INTEGER(KIND=JPIM) :: KULOUT INTEGER(KIND=JPIM) :: II,I,J,K,MYPROC,NPROC,ERROR,NODENUM,JID INTEGER(KIND=JPIB) :: TASKSMALL,NODEHUGE,MEMFREE,CACHED,NFREE INTEGER(KIND=JPIB),SAVE :: NODEHUGE_CACHED INTEGER(KIND=JPIB),SAVE :: NODEHUGE_PAGE_COUNT = 0 INTEGER(KIND=JPIM), PARAMETER :: MAXNUMA_DEF = 8 ! Max number of "sockets" supported by default INTEGER(KIND=JPIM), SAVE :: MAXNUMA = 0 ! Max number of "sockets" supported -- initialized to zero to enforce updated value (env EC_MAXNUMA) INTEGER(KIND=JPIM) :: NNUMA ! Actual number of "sockets" (can be 0 on systems that do not have /proc/buddyinfo, e.g. WSL) !INTEGER(KIND=JPIB),DIMENSION(0:MAXNUMA-1) :: SMALLPAGE,HUGEPAGE INTEGER(KIND=JPIB),DIMENSION(:),ALLOCATABLE,SAVE :: SMALLPAGE,HUGEPAGE INTEGER(KIND=JPIB) :: GETMAXRSS,GETMAXHWM INTEGER(KIND=JPIB) :: HEAP_SIZE INTEGER(KIND=JPIB), PARAMETER :: ONEMEGA = 1024_JPIB * 1024_JPIB INTEGER(KIND=JPIB) :: ENERGY, POWER INTEGER(KIND=JPIB) :: TOT_ENERGY, MAXPOWER, AVGPOWER INTEGER(KIND=JPIB) :: RUNNING, LOADAVG ! /proc/loadavg: running processes (parse 4th column thisvalue/totprocesses) and last 1 minute load (x 100) INTEGER(KIND=JPIB),SAVE :: PAGESIZE = 0 INTEGER(KIND=JPIM),SAVE :: MAXTH = 0 INTEGER(KIND=JPIM),SAVE :: MAXTH_COMP = 0 INTEGER(KIND=JPIM),SAVE :: MAXTH_IO = 0 INTEGER(KIND=JPIM),PARAMETER :: MAXCOLS = 18 ! Max numerical columns in /proc/buddyinfo (often just 11, but Cray has 18 entries) INTEGER(KIND=JPIM) :: N18 !INTEGER(KIND=JPIB),DIMENSION(0:MAXCOLS-1,0:MAXNUMA-1) :: NODE, BUCKET !INTEGER(KIND=JPIB),DIMENSION(7+2*MAXNUMA) :: SENDBUF,RECVBUF INTEGER(KIND=JPIB),DIMENSION(:,:),ALLOCATABLE,SAVE :: NODE, BUCKET INTEGER(KIND=JPIB),DIMENSION(:),ALLOCATABLE,SAVE :: SENDBUF,RECVBUF REAL(KIND=JPRD) :: PERCENT_USED(2) CHARACTER(LEN=256) :: CLSTR CHARACTER(LEN=512) :: TMPDIR CHARACTER(LEN=512), SAVE :: PROGRAM = ' ' CHARACTER(LEN=20) :: NODENAME,LASTNODE CHARACTER(LEN=12) :: VAL CHARACTER(LEN=160) ::LINE CHARACTER(LEN=1), save :: CLEC_MEMINFO = '1' CHARACTER(LEN=5) :: CSTAR #ifdef __PGI CHARACTER(LEN=64) :: ID_STRING #else CHARACTER(LEN=LEN(CSTAR)+1+LEN(CDSTRING)) :: ID_STRING #endif CHARACTER(LEN=10) :: CLDATEOD,CLTIMEOD,CLZONEOD CHARACTER(LEN=3), PARAMETER :: CLMON(1:12) = (/ & 'Jan','Feb','Mar','Apr','May','Jun', & 'Jul','Aug','Sep','Oct','Nov','Dec' /) INTEGER(KIND=JPIM) :: IVALUES(8), IMON LOGICAL :: LLNOCOMM, LLNOHDR INTEGER(KIND=JPIM), SAVE :: IAM_NODEMASTER = 0 LOGICAL, SAVE :: LLFIRST_TIME = .TRUE. TYPE RANKNODE_T INTEGER(KIND=JPIM) :: NODENUM INTEGER(KIND=JPIM) :: PID INTEGER(KIND=JPIM) :: RANK_WORLD INTEGER(KIND=JPIM) :: RANK INTEGER(KIND=JPIM) :: IORANK INTEGER(KIND=JPIM) :: NODEMASTER INTEGER(KIND=JPIM) :: NUMTH INTEGER(KIND=JPIM), ALLOCATABLE :: COREIDS(:) CHARACTER(LEN=LEN(NODENAME)) :: NODE CHARACTER(LEN=LEN(CLSTR)) :: STR END TYPE TYPE (RANKNODE_T), ALLOCATABLE, SAVE :: RN(:) INTEGER(KIND=JPIM), ALLOCATABLE :: COREIDS(:) LOGICAL, ALLOCATABLE :: DONE(:) INTEGER(KIND=JPIM), SAVE :: NUMNODES = 0 INTEGER(KIND=JPIM) :: NN INTEGER(KIND=JPIM), SAVE :: IOTASKS = 0 INTEGER(KIND=JPIM) :: IORANK, NSEND, NRECV REAL(KIND=JPRD), EXTERNAL :: UTIL_WALLTIME REAL(KIND=JPRD), SAVE :: WT0 REAL(KIND=JPRD) :: WT CHARACTER(LEN=64) :: CLPFX CHARACTER(LEN=3) :: ZUM INTEGER(KIND=JPIM) :: IPFXLEN, NUMTH, MYTH, IPID, ICOREID INTEGER, external :: EC_GETPID, EC_COREID ! from ec_env.c #ifdef MPL_F77_DEPRECATED INTEGER(KIND=JPIM) :: ICOMM INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE) #else TYPE(MPI_COMM) :: ICOMM TYPE(MPI_STATUS) :: IRECV_STATUS #endif INTEGER(KIND=JPIM) :: NCOMM_MEMINFO COMMON /cmn_meminfo/ NCOMM_MEMINFO !-- In case this file was compiled w/o OpenMP : INTEGER :: OMP_GET_MAX_THREADS, OMP_GET_THREAD_NUM #ifdef _OPENMP EXTERNAL OMP_GET_MAX_THREADS, OMP_GET_THREAD_NUM #else OMP_GET_MAX_THREADS() = 1 OMP_GET_THREAD_NUM() = 0 #endif IF (LLFIRST_TIME) THEN WT0 = UTIL_WALLTIME() CALL GET_ENVIRONMENT_VARIABLE('EC_MEMINFO',CLEC_MEMINFO) IF (CLEC_MEMINFO == '0') LLFIRST_TIME = .FALSE. ENDIF IF (CLEC_MEMINFO == '0') RETURN IF (MAXTH == 0) MAXTH = OMP_GET_MAX_THREADS() #ifdef MPL_F77_DEPRECATED ICOMM = KCOMM #else ICOMM%MPI_VAL = KCOMM #endif LLNOCOMM = (KCOMM == -1 .or. KCOMM == -2) LLNOHDR = (KCOMM == -2) IF (LLNOCOMM) THEN ! Direct call to obtain EC_meminfo -output ERROR = 0 MYPROC = 0 NPROC = 1 CLPFX = CDSTRING IPFXLEN = LEN_TRIM(CLPFX) ZUM = 'tsk' ELSE CLPFX = ' ' IPFXLEN = 0 ZUM = 'sum' CALL MPI_COMM_RANK(ICOMM,MYPROC,ERROR) CALL CHECK_ERROR("from MPI_COMM_RANK",__FILE__,__LINE__) CALL MPI_COMM_SIZE(ICOMM,NPROC,ERROR) CALL CHECK_ERROR("from MPI_COMM_SIZE",__FILE__,__LINE__) IF (KCALL == 0) THEN CALL CONDBARR(KBARR) CALL CHECK_ERROR("from MPI_BARRIER(at start)",__FILE__,__LINE__) ENDIF ENDIF IF (LLFIRST_TIME) THEN ! The *very* first time CALL EC_PMON(ENERGY,POWER) !-- Neither of these two may stop working when linking with C++ (like in OOPS) ... ! CALL GETARG(0,PROGRAM) ! CALL GET_COMMAND_ARGUMENT(0,PROGRAM) !... so using ec_args_mod: PROGRAM = EC_ARGV(0) PAGESIZE = 0 NODEHUGE_PAGE_COUNT = 0 !!234567890!234567890!234 !HugePages_Total: 24000 !Hugepagesize: 2048 kB OPEN(FILE="/proc/meminfo",UNIT=502,STATUS="old",ACTION="read",ERR=1977) DO WHILE (PAGESIZE == 0 .or. NODEHUGE_PAGE_COUNT == 0) READ(502,'(a)',ERR=1988,END=1988) LINE IF(LINE(1:15) == "HugePages_Total") THEN READ(LINE(17:25),*) NODEHUGE_PAGE_COUNT ELSEIF(LINE(1:12) == "Hugepagesize") THEN READ(LINE(14:25),*) PAGESIZE ! directly in kB ENDIF ENDDO 1988 continue CLOSE(502) 1977 continue NODEHUGE=NODEHUGE_PAGE_COUNT*PAGESIZE NODEHUGE=NODEHUGE/1024 NODEHUGE_CACHED = NODEHUGE ENDIF NODEHUGE=NODEHUGE_CACHED ! in MB CALL EC_GETHOSTNAME(NODENAME) ! from support/env.c IF (MAXNUMA == 0) THEN CALL GET_ENVIRONMENT_VARIABLE("EC_MAXNUMA",VAL) ! Note: *not* export EC_MEMINFO_MAXNUMA=, but EC_MAXNUMA= IF (VAL /= "") READ(VAL,*) MAXNUMA IF (MAXNUMA < 1) MAXNUMA = MAXNUMA_DEF ALLOCATE(SMALLPAGE(0:MAXNUMA-1)) ALLOCATE(HUGEPAGE(0:MAXNUMA-1)) ALLOCATE(NODE(0:MAXCOLS-1,0:MAXNUMA-1)) ALLOCATE(BUCKET(0:MAXCOLS-1,0:MAXNUMA-1)) ALLOCATE(SENDBUF(-1:7+2*MAXNUMA)) ALLOCATE(RECVBUF(-1:7+2*MAXNUMA)) ENDIF IF (MYPROC == 0) THEN ! ! Use already open file for output or $EC_MEMINFO_TMPDIR/meminfo ! We do not use $TMPDIR as it may have been inherited from mother superiour (MOMS) node ! IF(KU == -1) THEN CALL GET_ENVIRONMENT_VARIABLE('EC_MEMINFO_TMPDIR',TMPDIR) IF (TMPDIR == ' ') TMPDIR = '.' ! write(0,*) '## EC_MEMINFO: KCOMM=',KCOMM ! CALL LINUX_TRBK() KULOUT=501 OPEN(UNIT=KULOUT,FILE=TRIM(TMPDIR)//"/"//"meminfo.txt",STATUS='unknown', & & ACTION='write',POSITION='append') ELSE KULOUT=KU ENDIF ENDIF IF (LLFIRST_TIME .and. .not. LLNOCOMM) THEN ! Fetch affinities (over OpenMP threads) ! Note: I/O-tasks may now have different number of threads than on computational tasks ALLOCATE(COREIDS(0:MAXTH-1)) COREIDS(:) = -1 #ifdef _OPENMP !$OMP PARALLEL NUM_THREADS(MAXTH) SHARED(COREIDS) PRIVATE(I,MYTH,ICOREID) !$OMP DO SCHEDULE(STATIC,1) #endif DO I=1,MAXTH ICOREID = EC_COREID() MYTH = OMP_GET_THREAD_NUM() COREIDS(MYTH) = ICOREID ! False sharing here ENDDO #ifdef _OPENMP !$OMP END DO !$OMP END PARALLEL #endif ! Store the communicator we are in upon entering EC_MEMINFO for the first time -- to be used in the EC_MPI_FINALIZE NCOMM_MEMINFO = KCOMM ! Fetch node names & numbers per task IORANK = 0 IF (KIOTASK > 0) IORANK = 1 IF (MYPROC == 0) THEN CALL SLASH_PROC ALLOCATE(RN(0:NPROC-1)) DO I=0,NPROC-1 RN(I)%NODENUM = -1 IF (I > 0) THEN ! Receive in the MPI-rank order of KCOMM (i.e. may not be the same as MPI_COMM_WORLD -order) CALL MPI_RECV(LASTNODE,LEN(LASTNODE),MPI_BYTE,I,ITAG,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(LASTNODE)",__FILE__,__LINE__) CALL MPI_RECV(IORANK,1,MPI_INTEGER4,I,ITAG+1,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(IORANK)",__FILE__,__LINE__) CALL MPI_RECV(K,1,MPI_INTEGER4,I,ITAG+2,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(RANK_WORLD)",__FILE__,__LINE__) CALL MPI_RECV(IPID,1,MPI_INTEGER4,I,ITAG+3,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(GETPID)",__FILE__,__LINE__) CALL MPI_RECV(NUMTH,1,MPI_INTEGER4,I,ITAG+4,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(NUMTH)",__FILE__,__LINE__) CALL MPI_RECV(CLSTR,LEN(CLSTR),MPI_BYTE,I,ITAG+5,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(CLSTR)",__FILE__,__LINE__) RN(I)%RANK = I RN(I)%STR = CLSTR RN(I)%PID = IPID ELSE LASTNODE=NODENAME NUMTH = MAXTH CALL MPI_COMM_RANK(MPI_COMM_WORLD,K,ERROR) RN(I)%RANK = 0 ! Itself RN(I)%STR = CDSTRING RN(I)%PID = EC_GETPID() ENDIF RN(I)%RANK_WORLD = K RN(I)%IORANK = IORANK RN(I)%NODEMASTER = 0 RN(I)%NODE = LASTNODE ! Affinities RN(I)%NUMTH = NUMTH ALLOCATE(RN(I)%COREIDS(0:NUMTH-1)) IF (I > 0) THEN ! Receive in MPI-rank order CALL MPI_RECV(RN(I)%COREIDS,NUMTH,MPI_INTEGER4,I,ITAG+6,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(COREIDS)",__FILE__,__LINE__) ELSE RN(I)%COREIDS = COREIDS ENDIF IF (IORANK == 0) THEN MAXTH_COMP = MAX(MAXTH_COMP,NUMTH) ELSE MAXTH_IO = MAX(MAXTH_IO,NUMTH) ENDIF ENDDO CALL RNSORT(KULOUT) ! Output now goes to "meminfo.txt" IAM_NODEMASTER = RN(0)%NODEMASTER ! Itself DO I=1,NPROC-1 CALL MPI_SEND(RN(I)%NODEMASTER,1,MPI_INTEGER4,I,ITAG+7,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(IAM_NODEMASTER)",__FILE__,__LINE__) ENDDO ELSE CALL MPI_SEND(NODENAME,LEN(NODENAME),MPI_BYTE,0,ITAG,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(NODENAME)",__FILE__,__LINE__) CALL MPI_SEND(IORANK,1,MPI_INTEGER4,0,ITAG+1,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(IORANK)",__FILE__,__LINE__) CALL MPI_COMM_RANK(MPI_COMM_WORLD,K,ERROR) CALL MPI_SEND(K,1,MPI_INTEGER4,0,ITAG+2,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(RANK_WORLD)",__FILE__,__LINE__) IPID = EC_GETPID() CALL MPI_SEND(IPID,1,MPI_INTEGER4,0,ITAG+3,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(GETPID)",__FILE__,__LINE__) CALL MPI_SEND(MAXTH,1,MPI_INTEGER4,0,ITAG+4,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(MAXTH)",__FILE__,__LINE__) CLSTR = CDSTRING CALL MPI_SEND(CLSTR,LEN(CLSTR),MPI_BYTE,0,ITAG+5,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(CLSTR)",__FILE__,__LINE__) CALL MPI_SEND(COREIDS,MAXTH,MPI_INTEGER4,0,ITAG+6,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(COREIDS)",__FILE__,__LINE__) CALL MPI_RECV(IAM_NODEMASTER,1,MPI_INTEGER4,0,ITAG+7,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(IAM_NODEMASTER)",__FILE__,__LINE__) ENDIF DEALLOCATE(COREIDS) LLFIRST_TIME = .FALSE. CALL CONDBARR(KBARR) CALL CHECK_ERROR("from MPI_BARRIER near LLFIRST_TIME=.FALSE.",__FILE__,__LINE__) ENDIF IF (MYPROC == 0 .or. IAM_NODEMASTER == 1) CALL SLASH_PROC HEAP_SIZE=GETMAXHWM()/ONEMEGA TASKSMALL=GETMAXRSS()/ONEMEGA CALL PROC_LOADAVG ! Tracks potential run-away processes/threads from e.g. previous jobs IF (MYPROC == 0) THEN CALL DATE_AND_TIME(CLDATEOD,CLTIMEOD,CLZONEOD,IVALUES) READ(CLDATEOD(5:6),'(I2)') IMON IF (.not.LLNOCOMM .AND. KCALL /= 1) CALL PRT_DETAIL(KULOUT) IF (.not.LLNOHDR) CALL PRT_HDR(KULOUT,KCALL) IF(KU == -1) THEN IF (KCALL /= 1) CALL PRT_DETAIL(0) CALL PRT_HDR(0,KCALL) ENDIF ! Note: MYPROC == 0 is always at the RN(0) i.e. at the first NODENUM TOT_ENERGY = ENERGY MAXPOWER = POWER AVGPOWER = POWER LASTNODE = NODENAME NN = NUMNODES IF (LLNOCOMM) NN=1 IF (NPROC > 1) THEN ALLOCATE(DONE(1:NPROC-1)) DONE(:) = .FALSE. ENDIF DO NODENUM=1,NN JID = 0 DO II=1,NPROC-1 IF (.NOT.DONE(II)) THEN J = II ! Used to be REF(II) -- don't know why ?! IF (RN(J)%NODENUM == NODENUM) THEN I = RN(J)%RANK IF (RN(J)%NODEMASTER == 1) THEN ! Always the first task on a particular NODENUM LASTNODE = RN(J)%NODE NRECV = SIZE(RECVBUF) JID = J ! Always >= 1 ELSE NRECV = 4 ENDIF CALL MPI_RECV(RECVBUF,NRECV,MPI_INTEGER8,I,ITAG+8,ICOMM,IRECV_STATUS,ERROR) CALL CHECK_ERROR("from MPI_RECV(RECVBUF)",__FILE__,__LINE__) IF (NRECV > 4) THEN LOADAVG=RECVBUF(-1) RUNNING=RECVBUF(0) HEAP_SIZE=RECVBUF(1) TASKSMALL=RECVBUF(2) ENERGY=RECVBUF(3) POWER=RECVBUF(4) NODEHUGE=RECVBUF(5) MEMFREE=RECVBUF(6) CACHED=RECVBUF(7) DO K=0,MAXNUMA-1 SMALLPAGE(K) = RECVBUF(7+2*K+1) HUGEPAGE(K) = RECVBUF(7+2*K+2) ENDDO TOT_ENERGY = TOT_ENERGY + ENERGY IF (POWER > MAXPOWER) THEN MAXPOWER = POWER ENDIF AVGPOWER = AVGPOWER + POWER ELSE IF (LOADAVG < RECVBUF(-1)) LOADAVG = RECVBUF(-1) IF (RUNNING < RECVBUF(0)) RUNNING = RECVBUF(0) HEAP_SIZE=HEAP_SIZE+RECVBUF(1) TASKSMALL=TASKSMALL+RECVBUF(2) ENDIF DONE(II) = .TRUE. ENDIF ENDIF ENDDO PERCENT_USED(2) = 0 IF (NODEHUGE == 0 .or. HEAP_SIZE >= NODEHUGE) THEN ! running with small pages IF (TASKSMALL+NODEHUGE+MEMFREE+CACHED > 0) THEN PERCENT_USED(1) = 100.0*(TASKSMALL+NODEHUGE)/(TASKSMALL+NODEHUGE+MEMFREE+CACHED) ELSE PERCENT_USED(1) = 0 ENDIF CSTAR = " Sm/p" ELSE ! running with huge pages PERCENT_USED(1) = 100.0*(HEAP_SIZE+TASKSMALL)/(TASKSMALL+NODEHUGE+MEMFREE+CACHED) NFREE = 0 IF (NNUMA > 0) NFREE = SUM(HUGEPAGE(0:NNUMA-1)) PERCENT_USED(2) = (100.0*(NODEHUGE - NFREE))/NODEHUGE IF (PERCENT_USED(2) < 0) PERCENT_USED(2) = 0 IF (PERCENT_USED(2) > 100) PERCENT_USED(2) = 100 CSTAR = " Hg/p" ENDIF IF (LLNOCOMM) THEN ID_STRING = CSTAR ELSE IF (KCALL == 0 .AND. JID > 0) THEN ! This should signify the compute & I/O nodes (if they are separate) CLSTR = RN(JID)%STR ID_STRING = CSTAR//":"//TRIM(CLSTR) ELSE ID_STRING = CSTAR//":"//CDSTRING ENDIF CALL PRT_DATA(KULOUT,NODENUM,LASTNODE,KCALL) IF (KU == -1) THEN CALL PRT_DATA(0,NODENUM,LASTNODE,KCALL) IF (NODENUM == NN) THEN AVGPOWER = NINT(REAL(AVGPOWER)/REAL(NN)) CALL PRT_TOTAL_ENERGIES(KCALL, 0) CALL PRT_TOTAL_ENERGIES(KCALL, KULOUT) IF (KCALL == 1) THEN CALL DATE_AND_TIME(CLDATEOD,CLTIMEOD,CLZONEOD,IVALUES) READ(CLDATEOD(5:6),'(I2)') IMON CALL PRT_DETAIL(0) CALL PRT_DETAIL(KULOUT) ENDIF CALL PRT_EMPTY(KULOUT,1) CLOSE(KULOUT) ENDIF ENDIF ENDDO ! DO NODENUM=1,NN IF (ALLOCATED(DONE)) DEALLOCATE(DONE) ELSE SENDBUF(-1)=LOADAVG SENDBUF(0)=RUNNING SENDBUF(1)=HEAP_SIZE SENDBUF(2)=TASKSMALL IF (IAM_NODEMASTER == 1) THEN SENDBUF(3)=ENERGY SENDBUF(4)=POWER SENDBUF(5)=NODEHUGE SENDBUF(6)=MEMFREE SENDBUF(7)=CACHED DO K=0,MAXNUMA-1 SENDBUF(7+2*K+1)=SMALLPAGE(K) SENDBUF(7+2*K+2)=HUGEPAGE(K) ENDDO NSEND = SIZE(SENDBUF) ELSE NSEND = 4 ENDIF CALL MPI_SEND(SENDBUF,NSEND,MPI_INTEGER8,0,ITAG+8,ICOMM,ERROR) CALL CHECK_ERROR("from MPI_SEND(SENDBUF)",__FILE__,__LINE__) ENDIF IF (.not.LLNOCOMM) THEN CALL CONDBARR(KBARR) CALL CHECK_ERROR("from MPI_BARRIER(at end)",__FILE__,__LINE__) ENDIF CONTAINS SUBROUTINE SLASH_PROC IMPLICIT NONE INTEGER(KIND=JPIM) :: IDX, ICLKEYLEN #if defined(__powerpc64__) CHARACTER(LEN=*), PARAMETER :: CLKEY = " DMA " #else CHARACTER(LEN=*), PARAMETER :: CLKEY = " Normal " #endif ICLKEYLEN = LEN(CLKEY) CALL EC_PMON(ENERGY,POWER) N18 = 0 ! number of buddy columns (up to MAXCOLS) NNUMA = 0 ! number of NUMA-nodes (up to MAXNUMA) OPEN(FILE="/proc/buddyinfo",UNIT=502,STATUS="old",ACTION="read",ERR=97) #if defined(__powerpc64__) READ(502,'(a)',END=99) LINE #else READ(502,'(a)',END=99) LINE READ(502,'(a)',END=99) LINE READ(502,'(a)',END=99) LINE #endif IDX = INDEX(LINE,CLKEY) IF (IDX <= 0) GOTO 99 NODE(:,0)=-1 READ(LINE(IDX+ICLKEYLEN-1:),*,ERR=99,END=98) NODE(:,0) 98 CONTINUE N18 = COUNT(NODE(:,0) >= 0) NNUMA = 1 DO K=1,MAXNUMA-1 NODE(:,K)=0 READ(502,'(a)',END=99) LINE IDX = INDEX(LINE,CLKEY) IF (IDX <= 0) GOTO 99 READ(LINE(IDX+ICLKEYLEN-1:),*,ERR=99) NODE(0:N18-1,K) NNUMA = NNUMA + 1 ENDDO 99 CONTINUE CLOSE(502) 97 CONTINUE SMALLPAGE(:) = 0 HUGEPAGE(:) = 0 DO K=0,NNUMA-1 BUCKET(:,K) = 0 DO J=0,N18-1 BUCKET(J,K) = 4096_JPIB * NODE(J,K) * (2_JPIB ** J) ENDDO SMALLPAGE(K) = SUM(BUCKET(0:8,K))/ONEMEGA HUGEPAGE(K) = SUM(BUCKET(9:N18-1,K))/ONEMEGA ENDDO MEMFREE = 0 CACHED = 0 OPEN(FILE="/proc/meminfo",UNIT=502,STATUS="old",ACTION="read",ERR=977) DO I=1,10 READ(502,'(a)',ERR=988,END=988) LINE IF(LINE(1:7) == "MemFree") THEN READ(LINE(9:80),*) MEMFREE ELSEIF(LINE(1:6) == "Cached") THEN READ(LINE(8:80),*) CACHED ENDIF ENDDO 988 continue CLOSE(502) 977 continue MEMFREE=MEMFREE/1024 CACHED=CACHED/1024 END SUBROUTINE SLASH_PROC SUBROUTINE PRT_EMPTY(KUN,KOUNT) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUN,KOUNT INTEGER(KIND=JPIM) :: JJ DO JJ=1,KOUNT WRITE(KUN,'(a)') CLPFX(1:IPFXLEN)//"## EC_MEMINFO " ENDDO END SUBROUTINE PRT_EMPTY FUNCTION KWH(JOULES) IMPLICIT NONE INTEGER(KIND=JPIB), INTENT(IN) :: JOULES REAL(KIND=JPRD) KWH KWH = REAL(JOULES,JPRD) / 3600000.0_JPRD END FUNCTION KWH SUBROUTINE PRT_TOTAL_ENERGIES(KCALL, KUN) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KCALL INTEGER(KIND=JPIM), INTENT(IN) :: KUN IF (KCALL == 1) THEN ! last call WT = UTIL_WALLTIME() - WT0 CALL PRT_EMPTY(KUN,2) WRITE(KUN,'(a,a,f12.3,a,i0,a)') CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& & " Total energy consumed : ",KWH(TOT_ENERGY), " kWh (",TOT_ENERGY," J)" !-- Peak power below is misleading since based on values at sample points ! WRITE(KUN,'(a,a,i0,a)') CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& ! & " Peak power : ",MAXPOWER," W (node "//trim(CLMAXNODE)//")" !-- Avg power must be calculated based on total Joules divided by wall time and num nodes AVGPOWER = TOT_ENERGY / WT / NUMNODES WRITE(KUN,'(a,a,i0,a,i0,a)') CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& & " Avg. power / node : ",AVGPOWER," W across ",NUMNODES," nodes" CALL PRT_EMPTY(KUN,1) ENDIF END SUBROUTINE PRT_TOTAL_ENERGIES SUBROUTINE PRT_DETAIL(KUN) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUN CHARACTER(LEN=128) :: JOBNAME CHARACTER(LEN=128) :: JOBID CALL GET_ENVIRONMENT_VARIABLE('EC_JOB_NAME',JOBNAME) IF (JOBNAME == '') CALL GET_ENVIRONMENT_VARIABLE('PBS_JOBNAME',JOBNAME) IF (JOBNAME == '') CALL GET_ENVIRONMENT_VARIABLE('SLURM_JOB_NAME',JOBNAME) IF (JOBNAME == '') CALL GET_ENVIRONMENT_VARIABLE('EC_MEMINFO_JOBNAME',JOBNAME) CALL GET_ENVIRONMENT_VARIABLE('PBS_JOBID',JOBID) IF (JOBID == '') CALL GET_ENVIRONMENT_VARIABLE('SLURM_JOB_ID',JOBID) IF (JOBID == '') CALL GET_ENVIRONMENT_VARIABLE('EC_MEMINFO_JOBID',JOBID) CALL PRT_EMPTY(KUN,1) WT = UTIL_WALLTIME() - WT0 WRITE(KUN,'(4a,f10.3,a)') CLPFX(1:IPFXLEN)//"## EC_MEMINFO Detailed memory information ", & "for program ",TRIM(PROGRAM)," -- wall-time : ",WT,"s" WRITE(KUN,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a,a,":",a,":",a,a,a,"-",a,"-",a)') & CLPFX(1:IPFXLEN)//"## EC_MEMINFO Running on ",NUMNODES," nodes (",NNUMA,& "-numa) with ",NPROC-IOTASKS, & " compute + ",IOTASKS," I/O-tasks and ", MAXTH_COMP, "+", MAXTH_IO, " threads at ", & CLTIMEOD(1:2),CLTIMEOD(3:4),CLTIMEOD(5:10), & " on ",CLDATEOD(7:8),CLMON(IMON),CLDATEOD(1:4) WRITE(KUN,'(4a)') CLPFX(1:IPFXLEN)//"## EC_MEMINFO The Job Name is ",TRIM(JOBNAME), & " and the Job ID is ",TRIM(JOBID) CALL PRT_EMPTY(KUN,1) END SUBROUTINE PRT_DETAIL SUBROUTINE PRT_HDR(KUN,KCALL) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUN,KCALL INTEGER(KIND=JPIM) :: INUMA, ILEN CHARACTER(LEN=4096) :: CLBUF CHARACTER(LEN=7) :: CLTMP INUMA = NNUMA ILEN = 0 WRITE(CLBUF(ILEN+1:),'(A)') & CLPFX(1:IPFXLEN)//"## EC_MEMINFO | TC | MEMORY USED(MB) " ILEN = LEN_TRIM(CLBUF) DO K=0,INUMA-1 IF (K == 0) THEN WRITE(CLBUF(ILEN+1:),'(A)') " | MEMORY FREE(MB)" ILEN = LEN_TRIM(CLBUF) ELSE WRITE(CLBUF(ILEN+1:),'(A)') " ------------- " ILEN = LEN_TRIM(CLBUF) + 2 ENDIF ENDDO IF (KCALL == 0) THEN CLTMP = 'Running' ELSE CLTMP = 'LoadAvg' ENDIF IF (NNUMA > 0) THEN WRITE(CLBUF(ILEN+1:),'(A)') " INCLUDING CACHED| %USED %HUGE | Energy Power "//CLTMP ELSE WRITE(CLBUF(ILEN+1:),'(A)') " MEMORY FREE(MB) | %USED %HUGE | Energy Power "//CLTMP ENDIF WRITE(KUN,'(A)') TRIM(CLBUF) ILEN=0 WRITE(CLBUF(ILEN+1:),'(A)') & CLPFX(1:IPFXLEN)//"## EC_MEMINFO | Malloc| Inc Heap |" ILEN = LEN_TRIM(CLBUF) DO K=0,INUMA-1 WRITE(CLBUF(ILEN+1:),'(A,I2,A)') " Numa region ",K," |" ILEN = LEN_TRIM(CLBUF) ENDDO WRITE(CLBUF(ILEN+1:),'(A)') " | | (J) (W)" WRITE(KUN,'(A)') TRIM(CLBUF) ILEN=0 WRITE(CLBUF(ILEN+1:),'(A)') & CLPFX(1:IPFXLEN)//"## EC_MEMINFO Node Name | Heap | RSS("//zum//") |" ILEN = LEN_TRIM(CLBUF) DO K=0,INUMA-1 WRITE(CLBUF(ILEN+1:),'(A)') " Small Huge or |" ILEN = LEN_TRIM(CLBUF) ENDDO WRITE(CLBUF(ILEN+1:),'(A)') " Total |" WRITE(KUN,'(A)') TRIM(CLBUF) ILEN=0 WRITE(CLBUF(ILEN+1:),'(A)') & CLPFX(1:IPFXLEN)//"## EC_MEMINFO | (sum) | Small Huge |" ILEN = LEN_TRIM(CLBUF) DO K=0,INUMA-1 WRITE(CLBUF(ILEN+1:),'(A)') " Only Small |" ILEN = LEN_TRIM(CLBUF) ENDDO WRITE(CLBUF(ILEN+1:),'(A)') " Memfree+Cached |" WRITE(KUN,'(A)') TRIM(CLBUF) END SUBROUTINE PRT_HDR SUBROUTINE PRT_DATA(KUN,KNODENUM,CDLASTNODE,KCALL) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUN, KNODENUM, KCALL CHARACTER(LEN=*) , INTENT(IN) :: CDLASTNODE INTEGER(KIND=JPIM) :: INUMA,ILEN CHARACTER(LEN=4096) :: CLBUF CHARACTER(LEN=7) :: CLTMP REAL(KIND=JPRD) :: TMP INUMA = NNUMA ILEN=0 WRITE(CLBUF(ILEN+1:),'(a,i4,1x,a,3i8,1x)') & CLPFX(1:IPFXLEN)//"## EC_MEMINFO ", & KNODENUM-1,CDLASTNODE,HEAP_SIZE,TASKSMALL,NODEHUGE ILEN = LEN_TRIM(CLBUF) + 1 DO K=0,INUMA-1 WRITE(CLBUF(ILEN+1:),'(1x,2i8)') SMALLPAGE(K),HUGEPAGE(K) ILEN = LEN_TRIM(CLBUF) ENDDO IF (KCALL == 0) THEN WRITE(CLTMP,'(i7)') RUNNING ELSE TMP = REAL(LOADAVG,JPRD) * 0.01_JPRD WRITE(CLTMP,'(f7.2)') TMP ENDIF WRITE(CLBUF(ILEN+1:),'(2x,2i8,3x,2f6.1,1x,i9,1x,i6,1x,a7,1x,a)') & MEMFREE,CACHED, & PERCENT_USED,& ENERGY,POWER,& CLTMP,& trim(ID_STRING) WRITE(KUN,'(A)') TRIM(CLBUF) END SUBROUTINE PRT_DATA SUBROUTINE CONDBARR(KBARR) INTEGER(KIND=JPIM), INTENT(IN) :: KBARR IF (NPROC > 1 .and. KBARR /= 0) THEN CALL MPI_BARRIER(ICOMM,ERROR) ELSE ERROR = 0 ENDIF END SUBROUTINE CONDBARR SUBROUTINE CHECK_ERROR(CLWHAT,SRCFILE,SRCLINE) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: CLWHAT, SRCFILE INTEGER(KIND=JPIM), INTENT(IN) :: SRCLINE IF (ERROR /= 0) THEN WRITE(0,'(A,I0,1X,A,1X,"(",A,":",I0,")")') & & CLPFX(1:IPFXLEN)//"## EC_MEMINFO error code =",ERROR,CLWHAT,SRCFILE,SRCLINE CALL MPI_ABORT(ICOMM,-1,ERROR) ENDIF ERROR = 0 END SUBROUTINE CHECK_ERROR SUBROUTINE RNSORT(KUN) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KUN INTEGER(KIND=JPIM) :: ILEN INTEGER(KIND=JPIB) :: IHUGE CHARACTER(LEN=1) :: CLAST CHARACTER(LEN=4) :: CLMASTER CHARACTER(LEN=8192) :: CLBUF INTEGER(KIND=JPIM) :: impi_vers, impi_subvers, ilibrary_version_len INTEGER(KIND=JPIM) :: iomp_vers, iomp_subvers, iopenmp INTEGER(KIND=JPIM) :: JCOUNT, MINCID, MAXCID ! "CID" = core id INTEGER(KIND=JPIM), ALLOCATABLE :: NODE_CIDS(:,:) ! (MINCID:MAXCID) x NUMNODES CHARACTER(LEN=8192) :: clibrary_version CHARACTER(LEN=80) :: CL_CPUMODEL LOGICAL :: LLDONE(0:NPROC-1) INTEGER(KIND=JPIM) :: REF(0:NPROC-1) ! Keep list of the order tasks been added INTEGER(KIND=JPIM) :: IWORLD_RANK ! Index to IORANKS LLDONE(:) = .FALSE. IOTASKS = 0 K = 0 NODENUM = 0 MINCID = 9999999 MAXCID = 0 DO I=0,NPROC-1 IF (RN(I)%NODENUM == -1) THEN IF (RN(I)%IORANK == 1) THEN IOTASKS = IOTASKS + 1 RN(I)%IORANK = IOTASKS ELSE RN(I)%IORANK = 0 ENDIF NODENUM = NODENUM + 1 MINCID = MIN(MINCID,MINVAL(RN(I)%COREIDS(:))) MAXCID = MAX(MAXCID,MAXVAL(RN(I)%COREIDS(:))) RN(I)%NODENUM = NODENUM RN(I)%NODEMASTER = 1 LLDONE(I) = .TRUE. ! NB: Adjacent REF-elements allow us to operate with particular node's tasks that follow their the node-master REF(K) = I K = K + 1 LASTNODE = RN(I)%NODE ! DO J=I+1,NPROC-1 ! not valid anymore since ranks might have been reordered -- need to run through the whole list -- LLNODE speeds up DO J=0,NPROC-1 IF (.NOT.LLDONE(J)) THEN IF (RN(J)%NODENUM == -1) THEN IF (RN(J)%NODE == LASTNODE) THEN MINCID = MIN(MINCID,MINVAL(RN(J)%COREIDS(:))) MAXCID = MAX(MAXCID,MAXVAL(RN(J)%COREIDS(:))) RN(J)%NODENUM = NODENUM IF (RN(J)%IORANK == 1) THEN IOTASKS = IOTASKS + 1 RN(J)%IORANK = IOTASKS ELSE RN(J)%IORANK = 0 ENDIF RN(J)%NODEMASTER = 0 LLDONE(J) = .TRUE. REF(K) = J K = K + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ENDDO NUMNODES = NODENUM write(0,'(1X,A,3(1X,I0))') 'EC_MEMINFO@RNSORT: MINCID, MAXCID, NUMNODES = ',MINCID, MAXCID, NUMNODES ! debug -- to be removed ? ALLOCATE(NODE_CIDS(MINCID:MAXCID,NUMNODES)) NODE_CIDS(:,:) = 0 DO J=0,NPROC-1 NODENUM = RN(J)%NODENUM NODE_CIDS(RN(J)%COREIDS(:),NODENUM) = NODE_CIDS(RN(J)%COREIDS(:),NODENUM) + 1 ENDDO CALL ecmpi_version(impi_vers, impi_subvers, clibrary_version, ilibrary_version_len) call ecomp_version(iomp_vers, iomp_subvers, iopenmp) CALL EC_CPUMODEL(CL_CPUMODEL) ! ec_cpumodel from ../support/env.c CALL PRT_EMPTY(KUN,1) WRITE(KUN,'(a,i0,".",i0)') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : MPI-version ",impi_vers, impi_subvers WRITE(KUN,'(a)') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : Start of MPI-library version" WRITE(KUN,'(a)') trim(clibrary_version) ! This is could be multiline, a very long string WRITE(KUN,'(a)') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : End of MPI-library version" WRITE(KUN,'(a,i0,".",i0,".",i6.6)') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : OpenMP-version ",iomp_vers, iomp_subvers, iopenmp WRITE(KUN,'(a,a)') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : CPU-model : ",trim(CL_CPUMODEL) IF (PAGESIZE > 0) THEN IHUGE = INT(NODEHUGE_PAGE_COUNT,JPIB) * INT(PAGESIZE*1024,JPIB) WRITE(KUN,'(a,I0," bytes/page x ",I0," pages = ",I0," bytes")') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : Hugepages : ",PAGESIZE*1024,NODEHUGE_PAGE_COUNT,IHUGE ELSE WRITE(KUN,'(a)') & & CLPFX(1:IPFXLEN)//& & "## EC_MEMINFO : Hugepages : Not detected" ENDIF CALL PRT_EMPTY(KUN,2) WRITE(KUN,1003) & & CLPFX(1:IPFXLEN)//& &"## EC_MEMINFO ********************************************************************************",& & CLPFX(1:IPFXLEN)//& &"## EC_MEMINFO *** Mapping of MPI & I/O-tasks to nodes and tasks' thread-to-core affinities ***", & & CLPFX(1:IPFXLEN)//& &"## EC_MEMINFO ********************************************************************************" 1003 FORMAT((A)) CALL PRT_EMPTY(KUN,1) WRITE(KUN,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') & & CLPFX(1:IPFXLEN)//"## EC_MEMINFO Running on ",NUMNODES," nodes (",NNUMA,& & "-numa) with ",NPROC-IOTASKS, & & " compute + ",IOTASKS," I/O-tasks and ", MAXTH_COMP, "+", MAXTH_IO, " threads" CALL PRT_EMPTY(KUN,1) WRITE(KUN,1000) CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& & "#","NODE#","NODENAME","MPI#","WORLD#","GETPID","I/O#","MASTER","REF#","OMP#","Core affinities" WRITE(KUN,1000) CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& & "=","=====","========","====","======","======","====","======","====","====","===============" 1000 FORMAT(A,2(1X,A5),1X,A20,7(1X,A7),2X,A) CALL PRT_EMPTY(KUN,1) DO K=0,NPROC-1 ! Loop over the task as they have been added (see few lines earlier how REF(K) has been getting its values I or J) ILEN = 0 ! A formidable trick ? No need for a nested loop over 0:NPROC-1 to keep tasks within the same node together in the output I = REF(K) IWORLD_RANK = RN(I)%RANK_WORLD NUMTH = RN(I)%NUMTH CLMASTER = '[No]' IF (RN(I)%NODEMASTER == 1) CLMASTER = ' Yes' IF (RN(I)%IORANK > 0) THEN WRITE(CLBUF(ILEN+1:),1001) & & CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& & K,RN(I)%NODENUM-1,TRIM(ADJUSTL(RN(I)%NODE)),RN(I)%RANK,IWORLD_RANK,RN(I)%PID,& & RN(I)%IORANK-1,CLMASTER,I,NUMTH,"{" 1001 FORMAT(A,2(1X,I5),1X,A20,4(1X,I7),1X,A7,2(1X,I7),2X,A) ELSE WRITE(CLBUF(ILEN+1:),1002) & & CLPFX(1:IPFXLEN)//"## EC_MEMINFO ",& & K,RN(I)%NODENUM-1,TRIM(ADJUSTL(RN(I)%NODE)),RN(I)%RANK,IWORLD_RANK,RN(I)%PID,& & "[No]",CLMASTER,I,NUMTH,"{" 1002 FORMAT(A,2(1X,I5),1X,A20,3(1X,I7),2(1X,A7),2(1X,I7),2X,A) ENDIF ILEN = LEN_TRIM(CLBUF) CLAST = ',' NODENUM = RN(I)%NODENUM DO J=0,NUMTH-1 IF (J == NUMTH-1) CLAST = '}' ! Are there multiple coreids the same ? ICOREID = RN(I)%COREIDS(J) !JCOUNT = COUNT(RN(I)%COREIDS(:) == ICOREID) ! should be == 1 or thread binding has gone wrong JCOUNT = NODE_CIDS(ICOREID,NODENUM) ! # of ICOREID's referenced on this node (over all tasks) -- should be exactly one (1) IF (JCOUNT == 1) THEN WRITE(CLBUF(ILEN+1:),'(I0,A1)') ICOREID,CLAST ELSE ! mark with asterisk failed bindings WRITE(CLBUF(ILEN+1:),'(I0,A2)') ICOREID,'*'//CLAST ENDIF ILEN = LEN_TRIM(CLBUF) ENDDO WRITE(KUN,'(A,1X)') TRIM(CLBUF) ENDDO DEALLOCATE(NODE_CIDS) CALL PRT_EMPTY(KUN,1) CALL EC_FLUSH(KUN) END SUBROUTINE RNSORT SUBROUTINE PROC_LOADAVG IMPLICIT NONE INTEGER(KIND=JPIM) :: ISTAT, ISP1, ISP3, ISLASH REAL(KIND=JPRD) :: TMP CHARACTER(LEN=32) :: CLINE RUNNING = 0 LOADAVG = 0 ! 0.00 0.02 0.08 1/2562 77533 OPEN(506,FILE='/proc/loadavg',IOSTAT=ISTAT,STATUS='old',ACTION='read') IF (ISTAT == 0) THEN READ(506,'(A)',IOSTAT=ISTAT) CLINE CLOSE(506) ENDIF IF (ISTAT == 0) THEN ISLASH = SCAN(CLINE,'/') IF (ISLASH > 0) THEN ISP3 = SCAN(CLINE(:ISLASH-1),' ',BACK=.TRUE.) IF (ISP3 > 0) THEN READ(CLINE(ISP3+1:ISLASH-1),*,IOSTAT=ISTAT) RUNNING ISP1 = SCAN(CLINE(:ISP3-1),' ') IF (ISP1 > 0) THEN READ(CLINE(:ISP1-1),*,IOSTAT=ISTAT) TMP IF (ISTAT == 0) LOADAVG = INT(TMP * 100.0_JPRD) ENDIF ENDIF ENDIF ENDIF END SUBROUTINE PROC_LOADAVG END SUBROUTINE EC_MEMINFO fiat-ecmwf-2.0.0/src/fiat/util/ec_raise.c0000664000175000017500000000131115157200431020316 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ec_raise.c */ #include #include #include #include #include #include /* CALL ec_raise(6) == CALL abort() */ void ec_raise_(const int *sig) { raise(*sig); } void ec_raise(const int *sig) { ec_raise_(sig); } fiat-ecmwf-2.0.0/src/fiat/util/getopt.F900000664000175000017500000000635115157200431020173 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! FUNCTION GETOPT(Y_OPTSTR, Y_OPTARG) USE EC_PARKIND, ONLY : JPIM #ifdef NAGFOR use F90_UNIX, only: GETARG #endif IMPLICIT NONE INTEGER(KIND=JPIM) :: GETOPT CHARACTER(LEN=*) :: Y_OPTSTR, Y_OPTARG INTEGER(KIND=JPIM) :: I,INITIAL,L_OPTSTR INTEGER(KIND=JPIM) :: N_ARG,N_ARGS,NDX_ARG,NDX_OPT CHARACTER(LEN=512) :: Y_ARG CHARACTER(LEN=1) :: Y_OPT LOGICAL :: LL_ENDOPTS COMMON/GOPT_COM1/ INITIAL ,N_ARGS ,N_ARG ,NDX_ARG ,LL_ENDOPTS COMMON/GOPT_COM2/ Y_ARG ! Initialise on 1st. call ! ----------------------- IF (INITIAL .NE. 123456) THEN INITIAL = 123456 N_ARGS = COMMAND_ARGUMENT_COUNT() N_ARG = 0 NDX_ARG = 0 LL_ENDOPTS = .FALSE. ENDIF Y_OPTARG = ' ' ! Get length of "y_optstr" ! ------------------------ L_OPTSTR = 0 DO 10 I = LEN(Y_OPTSTR), 1, -1 IF (Y_OPTSTR(I : I) .NE. ' ') THEN L_OPTSTR = I GOTO 20 ENDIF 10 CONTINUE 20 CONTINUE ! If already at end of options, return ! ------------------------------------ IF ((N_ARG .GT. N_ARGS) .OR. LL_ENDOPTS) THEN LL_ENDOPTS = .TRUE. GETOPT = -1 RETURN ENDIF ! If we need to get the next argument, do so. Check for end of options ! -------------------------------------------------------------------- IF (NDX_ARG .EQ. 0) THEN N_ARG = N_ARG + 1 IF (N_ARG .GT. N_ARGS) THEN LL_ENDOPTS = .TRUE. GETOPT = -1 RETURN ENDIF Y_ARG = ' ' CALL GETARG(N_ARG, Y_ARG) NDX_ARG = 1 IF (Y_ARG(1 : 1) .NE. '-') THEN LL_ENDOPTS = .TRUE. GETOPT = -1 RETURN ELSE IF (Y_ARG .EQ. '--') THEN LL_ENDOPTS = .TRUE. N_ARG = N_ARG + 1 Y_ARG = ' ' IF (N_ARG .LE. N_ARGS) THEN CALL GETARG(N_ARG, Y_ARG) ENDIF GETOPT = -1 RETURN ENDIF NDX_ARG = 2 ENDIF ! We have an option, now see if it is valid ! ----------------------------------------- Y_OPT = Y_ARG(NDX_ARG : NDX_ARG) NDX_OPT = INDEX(Y_OPTSTR, Y_OPT) IF (NDX_OPT .EQ. 0) THEN NDX_ARG = NDX_ARG + 1 IF (Y_ARG(NDX_ARG : ) .EQ. ' ') THEN NDX_ARG = 0 ENDIF GETOPT = ICHAR(Y_OPT) RETURN ENDIF ! We have a valid option, see if it should have an argument ! --------------------------------------------------------- NDX_ARG = NDX_ARG + 1 IF (Y_ARG(NDX_ARG :) .EQ. ' ') THEN NDX_ARG = 0 ENDIF IF (NDX_OPT .EQ. L_OPTSTR) THEN GETOPT = ICHAR(Y_OPT) RETURN ELSE IF (Y_OPTSTR(NDX_OPT + 1 : NDX_OPT + 1) .NE. ':') THEN GETOPT = ICHAR(Y_OPT) RETURN ENDIF ! A valid option with an argument ! ------------------------------- IF (NDX_ARG .EQ. 0) THEN IF (N_ARG .EQ. N_ARGS) THEN LL_ENDOPTS = .TRUE. GETOPT = 0 RETURN ENDIF N_ARG = N_ARG + 1 Y_ARG = ' ' CALL GETARG(N_ARG, Y_ARG) NDX_ARG = 1 LL_ENDOPTS = N_ARG .EQ. N_ARGS ENDIF Y_OPTARG = Y_ARG(NDX_ARG : ) NDX_ARG = 0 GETOPT = ICHAR(Y_OPT) ENDFUNCTION GETOPT fiat-ecmwf-2.0.0/src/fiat/util/ec_env.c0000664000175000017500000003155315157200431020016 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* env.c */ /* Implement Fortran-callable ec_getenv and ec_putenv, since not all environments have getenv & putenv, but Unix/C library always have them */ /* Author: Sami Saarinen, ECMWF, 15-Mar-2006 */ //if (defined(__GNUC__) || defined(__PGI)) #define _GNU_SOURCE //endif #if defined(__APPLE__) #include #endif #include #include #include #include #include #include #include #include #include #include #include #include "raise.h" #if !defined(HOST_NAME_MAX) && defined(_POSIX_HOST_NAME_MAX) #define HOST_NAME_MAX _POSIX_HOST_NAME_MAX #endif #if !defined(HOST_NAME_MAX) && defined(_SC_HOST_NAME_MAX) #define HOST_NAME_MAX _SC_HOST_NAME_MAX #endif #if defined(HOST_NAME_MAX) #define EC_HOST_NAME_MAX HOST_NAME_MAX #else #define EC_HOST_NAME_MAX 512 #endif extern char **environ; /* Global Unix var */ static int numenv = 0; void ec_numenv_bind_c(int *n) { /* Returns the number of environment variables currently active */ int j=0; if (environ) { for (; environ[j]; j++) { } } if (n) *n = j; numenv = j; /* Not thread-safe */ } void ec_environ_bind_c(const int *i, char *value, /* Hidden arguments */ const int valuelen) { /* Returns (*i)'th environment number; Note: "Fortran", not "C" range between [1..numenv] */ int j = (i && environ) ? (*i) : 0; memset(value, ' ', valuelen); if (j >= 1 && j <= numenv) { char *p = environ[--j]; if (p) { int len = strlen(p); if (valuelen < len) len = valuelen; memcpy(value,p,len); } } } void ec_getenv_bind_c(const char *s, char *value, /* Hidden arguments */ int slen, const int valuelen) { char *env = NULL; char *p = malloc(slen+1); if (!p) { fprintf(stderr,"ec_getenv_(): Unable to allocate %d bytes of memory\n", slen+1); ABOR1("ec_getenv_(): Unable to allocate memory"); } memcpy(p,s,slen); p[slen]='\0'; memset(value, ' ', valuelen); env = getenv(p); if (env) { int len = strlen(env); if (valuelen < len) len = valuelen; memcpy(value,env,len); } free(p); } void ec_putenv_overwrite_bind_c(const char *s, /* Hidden argument */ int slen) { const char *x = &s[slen-1]; /* strip trailing blanks first */ while (slen > 0 && *x == ' ') { --slen; --x; } /* now go ahead */ if (slen > 0) { char *p = malloc(slen+1); if (!p) { fprintf(stderr,"ec_putenv_(): Unable to allocate %d bytes of memory\n", slen+1); ABOR1("ec_putenv_(): Unable to allocate memory"); } memcpy(p,s,slen); p[slen]='\0'; putenv(p); /* Cannot free(p); , since putenv() uses this memory area for good ;-( */ } } void ec_putenv_nooverwrite_bind_c(const char *s, /* Hidden argument */ int slen) { const char *x = &s[slen-1]; /* strip trailing blanks first */ while (slen > 0 && *x == ' ') { --slen; --x; } /* now go ahead */ if (slen > 0) { char *eq = NULL; char *p = malloc(slen+1); if (!p) { fprintf(stderr,"ec_putenv_nooverwrite_(): Unable to allocate %d bytes of memory\n", slen+1); ABOR1("ec_putenv_nooverwrite_(): Unable to allocate memory"); } memcpy(p,s,slen); p[slen]='\0'; eq = strchr(p,'='); if (eq) { char *env = NULL; *eq = '\0'; env = getenv(p); if (env) { /* Already found ==> do not overwrite */ free(p); return; } else { /* Reset '=' back and continue with putenv() */ *eq = '='; } } putenv(p); /* Cannot free(p); , since putenv() uses this memory area for good ;-( */ } } /*--- sleep_by_spinning ---*/ static int sleep_by_spinning(long secs, long nanosecs) { /* see also drhook.c */ /* This does not call sleep() at all i.e. is not SIGALRM driven */ int rc; struct timespec req, rem; req.tv_sec = secs; req.tv_nsec = nanosecs; rc = nanosleep(&req, &rem); if (rc == -1) { if (errno == EINTR) { rc = rem.tv_sec; } else rc = 0; /* Can't do much more about this */ } return rc; } unsigned int ec_sleep_(const int *nsec) { //return sleep((nsec && *nsec > 0) ? *nsec : 0); return sleep_by_spinning((nsec && *nsec > 0) ? *nsec : 0, 0); } unsigned int ec_sleep(const int nsec) { return ec_sleep_(&nsec); } /* Microsecond-sleep, by S.Saarinen, 25-Jan-2008 */ void /* Global, C-callable, too */ ec_microsleep(int usecs) { if (usecs > 0) { struct timeval t; t.tv_sec = usecs/1000000; t.tv_usec = usecs%1000000; // (void) select(0, NULL, NULL, NULL, &t); (void) sleep_by_spinning(t.tv_sec, (long)1000*t.tv_usec); } } void ec_usleep_(const int *usecs) { if (usecs && *usecs > 0) ec_microsleep(*usecs); } void ec_usleep(const int *usecs) { ec_usleep_(usecs); } /* ec_gethostname , by S.Saarinen, 30-Sep-2016 */ /* ec_getpaddedhost , -"- , 13-Jul-2021 */ void ec_getpaddedhost_(char a[], const int *padding, /* a char */ /* Hidden argument */ int alen) { char s[EC_HOST_NAME_MAX]; int c = padding ? *padding : (int) ' '; memset(a,c,alen); if (gethostname(s,sizeof(s)) == 0) { int len; char *pdot = strchr(s,'.'); if (pdot) *pdot = '\0'; // cut short from "." char e.g. hostname.fmi.fi becomes just "hostname" len = strlen(s); if (len > alen) len = alen; memcpy(a,s,len); } } void ec_getpaddedhost(char a[], const int *padding, /* a char */ /* Hidden argument */ int alen) { ec_getpaddedhost_(a,padding,alen); } void ec_gethostname_(char a[], /* Hidden argument */ int alen) { char s[EC_HOST_NAME_MAX]; memset(a,' ',alen); if (gethostname(s,sizeof(s)) == 0) { int len; char *pdot = strchr(s,'.'); if (pdot) *pdot = '\0'; // cut short from "." char e.g. hostname.fmi.fi becomes just "hostname" len = strlen(s); if (len > alen) len = alen; memcpy(a,s,len); } } void ec_gethostname(char a[], /* Hidden argument */ int alen) { ec_gethostname_(a,alen); } /* ec_coreid(): For checking runtime affinities (not setting them, though) */ #if defined(LINUX) #include int sched_getcpu(void); #define getcpu() sched_getcpu() #else #define getcpu() -1 #endif int ec_coreid_() { return getcpu(); } int ec_coreid() { return ec_coreid_(); } #ifndef SYS_gettid #define SYS_gettid __NR_gettid #endif static pid_t GETtid() { #if defined(__APPLE__) uint64_t tid64; pthread_threadid_np(NULL, &tid64); pid_t tid = (pid_t)tid64; #else pid_t tid = syscall(SYS_gettid); #endif return tid; } int ec_getpid_() { // Your Fortran did not recognize GETPID() ? Use then: mypid = ec_getpid() return (int)getpid(); } int ec_getpid() { // C-callable return ec_getpid_(); } int ec_gettid_() { // Your Fortran did not recognize GETTID() ? Use then: mypid = ec_gettid() return (int)GETtid(); } int ec_gettid() { // C-callable return ec_gettid_(); } #if defined(__APPLE__) // These variables and functions are Linux specific static int CPU_SETSIZE = 0; typedef struct cpu_set_t cpu_set_t; struct cpu_set_t {}; static int CPU_ISSET(int index, const cpu_set_t* cpu_set) { return 0; } static void CPU_ZERO(cpu_set_t* cpu_set) {} static int sched_getaffinity(pid_t pid, size_t size, cpu_set_t* cpu_set) { return 0; } #endif static char *cpuset_to_cstr(const cpu_set_t *cpuset, char str[], const int lenstr) { char *ptr = str; int len = lenstr; int off = 0; int i, entry_made = 0; for (i = 0; i < CPU_SETSIZE; i++) { if (CPU_ISSET(i, cpuset)) { int j, run = 0; if (!entry_made) entry_made = 1; for (j = i + 1; j < CPU_SETSIZE; j++) { if (CPU_ISSET(j, cpuset)) run++; else break; } if (!run) { snprintf(ptr+off, len-off, "%d,", i); } else if (run == 1) { snprintf(ptr+off, len-off, "%d,%d,", i, i + 1); i++; } else { snprintf(ptr+off, len-off, "%d-%d,", i, i + run); i += run; } off = strlen(ptr); } } *(ptr+off-entry_made) = '\0'; // remove char (usually ",") return ptr; } /* ec_affinity(): Returns compact thread affinity string to Fortran */ void ec_affinity_(char s[], // hidden const int slen) { if (slen > 0) { cpu_set_t coremask; char *p, str[CPU_SETSIZE * 8]; pid_t tid = GETtid(); CPU_ZERO(&coremask); (void) sched_getaffinity(tid,sizeof(coremask),&coremask); p = cpuset_to_cstr(&coremask, str, sizeof(str)); memset(s,' ',slen); if (p) { int plen = strlen(p); if (plen > slen) plen = slen; memcpy(s,p,plen); } } } void ec_affinity(char s[], // hidden const int slen) { ec_affinity_(s,slen); } #ifdef DARSHAN /* Some issues with Darshan -- better to use our own version of MPI_Wtime (mpi_wtime_ in Fortran) */ double mpi_wtime_() { extern double util_walltime_(); /* from drhook.c */ return util_walltime_(); } #endif /* ec_mpi_epoch(): Is used (indirectly) to calculate pretty accurate MPI_Init*() overhead */ double ec_mpi_epoch_() { double epoch = 0; #if 1 // Avoids fork() struct timeval tbuf; if (gettimeofday(&tbuf,NULL) == -1) perror("ec_mpi_epoch_"); epoch = (double) tbuf.tv_sec + (tbuf.tv_usec / 1000000.0); // should be aligned with /bin/date #else // With (v)fork() -- do NOT use this FILE *fp = popen("/bin/date +%s.%N","r"); if (fp) { fscanf(fp,"%lf",&epoch); pclose(fp); } #endif return epoch; } double ec_mpi_epoch() { return ec_mpi_epoch_(); } /* ec_cpumodel(): Returns CPU model of this platform */ void ec_cpumodel_(char *s, /* hidden arg */ const int slen) { FILE *fp = fopen("/proc/cpuinfo","r"); memset(s,' ',slen); if (fp) { const char target[] = "model name\t: "; int tlen = strlen(target); char p[4096]; while (!feof(fp) && fgets(p,sizeof(p),fp)) { if (strncmp(p,target,tlen) == 0) { // egrep ^ int len; char *nl = strchr(p,'\n'); if (nl) *nl = '\0'; len = strlen(p+tlen); if (slen < len) len = slen; memcpy(s,p+tlen,len); break; } } fclose(fp); } } void ec_cpumodel(char *s, /* hidden arg */ const int slen) { ec_cpumodel_(s, slen); } /* ec_mpirank(): Sometimes we need to know MPI_COMM_WORLD's "myrank" aka "me" before MPI_Init*() was even been called */ /* ec_mpisize(): Sometimes we need to know MPI_COMM_WORLD's number of ranks before MPI_Init*() was even been called */ int ec_mpirank_() { static int me = -1; /* MPI task id >= 0 && <= max tasks - 1 */ if (me < 0) { /* Trying to figure out MPI task id *before* MPI_Init*() was called */ char *env_mpirank = NULL; if (!env_mpirank) env_mpirank = getenv("PMI_FORK_RANK"); // Cray MPICH : when invoked with PMI_NO_FORK=1 if (!env_mpirank) env_mpirank = getenv("ALPS_APP_PE"); // Cray ALPS if (!env_mpirank) env_mpirank = getenv("PMIX_RANK"); // OpenMPI when using "srun" and SLURM_MPI_TYPE=pmix if (!env_mpirank) env_mpirank = getenv("PMI_RANK"); // MPICH (except Cray MPICH) -- also SLURM "srun" regardless of MPI implementation if (!env_mpirank) env_mpirank = getenv("OMPI_COMM_WORLD_RANK"); // Genuine OpenMPI if (!env_mpirank) env_mpirank = getenv("EC_FARM_ID"); // ECMWF extension if (env_mpirank) me = atoi(env_mpirank); if (me < 0) me = 0; // Bailing out } return me; } int ec_mpirank() { return ec_mpirank_(); } int ec_mpisize_() { static int numranks = 0; if (numranks < 1) { char *env_mpisize = NULL; // Please note : Cray ALPS does NOT have any specific "ALPS_APP_SIZE" or similar !!! if (!env_mpisize) env_mpisize = getenv("PMIX_SIZE"); // OpenMPI when using srun and SLURM_MPI_TYPE=pmix : actually this ALSO does NOT exist !!! if (!env_mpisize) env_mpisize = getenv("PMI_SIZE"); // MPICH (except Cray MPICH) -- also SLURM "srun" regardless of MPI implementation (also for SLURM_MPI_TYPE=pmix) if (!env_mpisize) env_mpisize = getenv("OMPI_COMM_WORLD_SIZE"); // Genuine OpenMPI if (!env_mpisize) env_mpisize = getenv("SLURM_NTASKS"); // If SLURM (--ntasks=value or -n value) if (!env_mpisize) env_mpisize = getenv("SLURM_NPROCS"); // If SLURM (--ntasks=value or -n value) -- backward compatible with SLURM_NTASKS if (!env_mpisize) env_mpisize = getenv("EC_FARM_SIZE"); // ECMWF extension if (env_mpisize) numranks = atoi(env_mpisize); if (numranks < 1) numranks = 1; } return numranks; } int ec_mpisize() { return ec_mpisize_(); } fiat-ecmwf-2.0.0/src/fiat/util/ec_set_umask.c0000664000175000017500000000173215157200431021215 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ec_set_umask.c */ #include #include #include #include #include #include void ec_set_umask_(void) { char *env = getenv("EC_SET_UMASK"); if (env) { int newmask; int n = sscanf(env,"%o",&newmask); if (n == 1) { int oldmask = umask(newmask); fprintf(stderr, "*** EC_SET_UMASK : new/old = %o/%o (oct), %d/%d (dec), %x/%x (hex)\n", newmask,oldmask, newmask,oldmask, newmask,oldmask); } /* if (n == 1) */ } /* if (env) */ } fiat-ecmwf-2.0.0/src/fiat/util/ec_parkind.F900000664000175000017500000000165515157200431020772 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE EC_PARKIND ! ! *** Define usual kinds for strong typing *** ! USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T IMPLICIT NONE PRIVATE :: C_INTPTR_T SAVE ! ! Integer Kinds ! ------------- ! INTEGER, PARAMETER :: JPIM = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: JPIB = SELECTED_INT_KIND(12) INTEGER, PARAMETER :: JPIA = C_INTPTR_T ! ! Real Kinds ! ---------- ! INTEGER, PARAMETER :: JPRM = SELECTED_REAL_KIND(6,37) INTEGER, PARAMETER :: JPRD = SELECTED_REAL_KIND(13,300) END MODULE EC_PARKIND fiat-ecmwf-2.0.0/src/fiat/util/loc_addr.c0000664000175000017500000000105015157200431020313 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* loc()-function */ #include intptr_t loc_addr_(const char *p) { return (intptr_t)(p) - (intptr_t)(0); } fiat-ecmwf-2.0.0/src/fiat/util/ec_datetime_mod.F900000664000175000017500000002161515157200431021773 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE EC_DATETIME_MOD !**** Interface to eclib's date-time routines ! Purpose. ! -------- ! Fortran 90 Interface to calling eclib date-time routines ! Author. ! ------- ! W.Deconinck ECMWF ! Modifications. ! -------------- ! Original: 2021-05-10 ! ------------------------------------------------------------------ IMPLICIT NONE PRIVATE PUBLIC :: cd2date, yd2date, idate2cd, idate2yd, icd2ymd, iymd2cd PUBLIC :: daydiff, hourdiff, mindiff, secdiff PUBLIC :: hourincr, minincr, secincr ! ISO-C-BINDING C-interfaces INTERFACE ! void cd2date(const int32_t *const icd, int32_t *const iy, int32_t *const im, int32_t *const id, int32_t *const iret); subroutine cd2date( & & cd, & & year, month, day, & & iret) & & bind(c, name="cd2date") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: cd integer(c_int32_t), intent(out) :: year, month, day integer(c_int32_t), intent(out) :: iret end subroutine ! void yd2date(const int32_t *const iyd, const int32_t *const iy, int32_t *const im, int32_t *const id, int32_t *const iret); subroutine yd2date( & & yearday, year, & & month, day, & & iret) & & bind(c, name="yd2date") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: yearday, year integer(c_int32_t), intent(out) :: month, day integer(c_int32_t), intent(out) :: iret end subroutine ! int32_t idate2cd(const int32_t *const iy, const int32_t *const im, const int32_t *const id, int32_t *const iret); function idate2cd( & & year, month, day, & & iret) & & bind(c, name="idate2cd") use, intrinsic :: iso_c_binding integer(c_int32_t) :: idate2cd integer(c_int32_t), intent(in) :: year, month, day integer(c_int32_t), intent(out) :: iret end function ! int32_t idate2yd(const int32_t *const iy, const int32_t *const im, const int32_t *const id, int32_t *const iret); function idate2yd( & & year, month, day, & & iret) & & bind(c, name="idate2yd") use, intrinsic :: iso_c_binding integer(c_int32_t) :: idate2yd integer(c_int32_t), intent(in) :: year, month, day integer(c_int32_t), intent(out) :: iret end function ! int32_t icd2ymd(const int32_t *const icd, int32_t *const iret); function icd2ymd( & & cd, & & iret) & & bind(c, name="icd2ymd") use, intrinsic :: iso_c_binding integer(c_int32_t) :: icd2ymd integer(c_int32_t), intent(in) :: cd integer(c_int32_t), intent(out) :: iret end function ! int32_t iymd2cd(const int32_t *const iymd, int32_t *const iret); function iymd2cd( & & ymd, & & iret) & & bind(c, name="iymd2cd") use, intrinsic :: iso_c_binding integer(c_int32_t) :: iymd2cd integer(c_int32_t), intent(in) :: ymd integer(c_int32_t), intent(out) :: iret end function ! void daydiff(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, ! const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, ! int32_t *const days, int32_t *const iret); subroutine daydiff( & & year1, month1, day1, & & year2, month2, day2, & & days, & & iret) & & bind(c, name="daydiff") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year1, month1, day1 integer(c_int32_t), intent(in) :: year2, month2, day2 integer(c_int32_t), intent(out) :: days, iret end subroutine ! void hourdiff(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, ! const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, ! int32_t *const hours, int32_t *const iret); subroutine hourdiff( & & year1, month1, day1, hour1, & & year2, month2, day2, hour2, & & hours, & & iret) & & bind(c, name="hourdiff") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year1, month1, day1, hour1 integer(c_int32_t), intent(in) :: year2, month2, day2, hour2 integer(c_int32_t), intent(out) :: hours, iret end subroutine ! void mindiff(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, ! const int32_t *const hour1, const int32_t *const min1, ! const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, ! const int32_t *const hour2, const int32_t *const min2, ! int32_t *const minutes, int32_t *const iret); subroutine mindiff( & & year1, month1, day1, hour1, min1, & & year2, month2, day2, hour2, min2, & & minutes, & & iret) & & bind(c, name="mindiff") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year1, month1, day1, hour1, min1 integer(c_int32_t), intent(in) :: year2, month2, day2, hour2, min2 integer(c_int32_t), intent(out) :: minutes, iret end subroutine ! void secdiff(const int32_t *const year1, const int32_t *const month1, const int32_t *const day1, const int32_t *const hour1, ! const int32_t *const min1, const int32_t *const sec1, ! const int32_t *const year2, const int32_t *const month2, const int32_t *const day2, const int32_t *const hour2, ! const int32_t *const min2, const int32_t *const sec2, ! int32_t *const seconds, int32_t *const iret); subroutine secdiff( & & year1, month1, day1, hour1, min1, sec1, & & year2, month2, day2, hour2, min2, sec2, & & seconds, & & iret) & & bind(c, name="secdiff") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year1, month1, day1, hour1, min1, sec1 integer(c_int32_t), intent(in) :: year2, month2, day2, hour2, min2, sec2 integer(c_int32_t), intent(out) :: seconds, iret end subroutine ! void hourincr(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, ! const int32_t *const hours, ! int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, ! int32_t *const iret); subroutine hourincr( & & year, month, day, hour, & & hours, & & new_year, new_month, new_day, new_hour, & & iret) & & bind(c, name="hourincr") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year, month, day, hour, hours integer(c_int32_t), intent(out) :: new_year, new_month, new_day, new_hour, iret end subroutine ! void minincr(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, ! const int32_t *const min, ! const int32_t *const minutes,int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, ! int32_t *const new_hour, int32_t *const new_min, int32_t *const iret); subroutine minincr( & & year, month, day, hour, min, & & minutes, & & new_year, new_month, new_day, new_hour, new_min, & & iret) & & bind(c, name="minincr") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year, month, day, hour, min, minutes integer(c_int32_t), intent(out) :: new_year, new_month, new_day, new_hour, new_min, iret end subroutine ! void secincr(const int32_t *const year, const int32_t *const month, const int32_t *const day, const int32_t *const hour, ! const int32_t *const min, const int32_t *const sec, const int32_t *const seconds, ! int32_t *const new_year, int32_t *const new_month, int32_t *const new_day, int32_t *const new_hour, ! int32_t *const new_min, int32_t *const new_sec, int32_t *const iret); subroutine secincr( & & year, month, day, hour, min, sec, & & seconds, & & new_year, new_month, new_day, new_hour, new_min, new_sec, & & iret) & & bind(c, name="secincr") use, intrinsic :: iso_c_binding integer(c_int32_t), intent(in) :: year, month, day, hour, min, sec, seconds integer(c_int32_t), intent(out) :: new_year, new_month, new_day, new_hour, new_min, new_sec, iret end subroutine END INTERFACE CONTAINS END MODULE fiat-ecmwf-2.0.0/src/fiat/util/abor1_c.c0000664000175000017500000000173515157200431020064 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include extern void abor1fl_(const char *filename, const int *linenum, const char *s, int filenamelen, int slen); extern void abor1_(const char *s, int slen); void abor1(const char* filename, const int linenum, const char* s) { if( filename ) { s ? abor1fl_( filename, &linenum, s, strlen(filename), strlen(s) ) : abor1fl_( filename, &linenum, "", strlen(filename), 0 ); } else { s ? abor1_( s, strlen(s) ) : abor1_( "", 0 ); } _exit(1); /* Should never end up here */ } fiat-ecmwf-2.0.0/src/fiat/util/abor1.F900000664000175000017500000001016315157200431017671 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! SUBROUTINE ABOR1FL(CDFILE, KLINENUM, CDTEXT) !! Abort that prints file, line, and message !! Tracebacks will be printed if possible !! All processes will be terminated in parallel MPI context USE EC_PARKIND ,ONLY : JPIM USE EC_LUN ,ONLY : NULOUT, NULERR USE MPL_MODULE ,ONLY : MPL_ABORT USE OML_MOD ,ONLY : OML_MY_THREAD IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: CDFILE INTEGER(KIND=JPIM), INTENT(IN) :: KLINENUM CHARACTER(LEN=*), INTENT(IN) :: CDTEXT IF (LEN(CDFILE) > 0 .AND. KLINENUM > 0) THEN IF (NULOUT >= 0 .AND. NULOUT /= 6 .AND. NULOUT /= NULERR) THEN WRITE(NULOUT,'(A,I0,A,I0,A,A,A,I0,A,A)') 'ABOR1 [PROC=',MYPROC(),',THRD=',OML_MY_THREAD(),'] from [',CDFILE,' +',KLINENUM,'] : ', CDTEXT ENDIF IF (NULERR >= 0) THEN WRITE(NULERR,'(A,I0,A,I0,A,A,A,I0,A,A)') 'ABOR1 [PROC=',MYPROC(),',THRD=',OML_MY_THREAD(),'] from [',CDFILE,' +',KLINENUM,'] : ', CDTEXT ENDIF ELSE IF (NULOUT >= 0 .AND. NULOUT /= 6 .AND. NULOUT /= NULERR) THEN WRITE(NULOUT,'(A,I0,A,I0,A,A)') 'ABOR1 [PROC=',MYPROC(),',THRD=',OML_MY_THREAD(),'] : ', CDTEXT ENDIF IF (NULERR >= 0 ) THEN WRITE(NULERR,'(A,I0,A,I0,A,A)') 'ABOR1 [PROC=',MYPROC(),',THRD=',OML_MY_THREAD(),'] : ', CDTEXT ENDIF ENDIF IF (NULOUT >= 0) THEN CALL EC_FLUSH(NULOUT) IF (NULOUT /= 0 .AND. NULOUT /= 6) CLOSE(NULOUT) ENDIF CALL EC_FLUSH(NULERR) IF(LEN(CDTEXT) <= 512) THEN CALL MPL_ABORT(CDTEXT) ELSE CALL MPL_ABORT ENDIF CONTAINS FUNCTION MYPROC() RESULT(IPROC) USE MPL_MPI IMPLICIT NONE INTEGER(KIND=JPIM) :: IERROR,IPROC LOGICAL :: LMPI_INITIALIZED IPROC = 1 CALL MPI_INITIALIZED(LMPI_INITIALIZED,IERROR) ! always thread safe, see standard ! IF( LMPI_INITIALIZED ) THEN CALL MPI_COMM_RANK(MPI_COMM_WORLD,IPROC,IERROR) ! always thread safe, see standard ! IPROC = IPROC+1 ! 1-based in IFS context ENDIF END FUNCTION END SUBROUTINE ABOR1FL SUBROUTINE ABOR1(CDTEXT) !! Abort that prints message without file and line number !! Delegates to ABOR1FL !! Tracebacks will be printed if possible !! All processes will be terminated in parallel MPI context USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: CDTEXT INTEGER(KIND=JPIM) :: ILINENUM ILINENUM=0_JPIM CALL ABOR1FL("",ILINENUM,CDTEXT) END SUBROUTINE ABOR1 SUBROUTINE ABOR1_EXCEPTION_HANDLER() !! This routine, when registered as the fckit exception handler, will be called !! whenever any C++ exception is thrown. The exception is intercepted and can !! be inquired through the variable FCKIT_EXCEPTION. !! An exception can also be thrown within Fortran: !! CALL FCKIT_EXCEPTION%ABORT("I have my reasons") #ifdef WITH_FCKIT USE FCKIT_MODULE, ONLY : FCKIT_EXCEPTION IF( FCKIT_EXCEPTION%LOCATION%IS_SET() ) then CALL ABOR1FL( FCKIT_EXCEPTION%LOCATION%FILE(), FCKIT_EXCEPTION%LOCATION%LINE(), FCKIT_EXCEPTION%WHAT() ) ELSE CALL ABOR1( FCKIT_EXCEPTION%WHAT() ) ENDIF #else CALL ABOR1( "An unknown exception is handled via ABOR1_EXCEPTION_HANDLER. Compile fiat with fckit to get a better error message" ) #endif END SUBROUTINE SUBROUTINE SET_ABOR1_EXCEPTION_HANDLER() BIND(C,NAME="set_abor1_exception_handler") !! This routine registers ABOR1 as the C++ exception handler, will be called !! whenever any C++ exception is thrown and not caught. !! The exception is intercepted and can be inquired through !! the variable FCKIT_EXCEPTION. !! An exception can also be thrown within Fortran: !! CALL FCKIT_EXCEPTION%ABORT("I have my reasons") #ifdef WITH_FCKIT USE FCKIT_MODULE, ONLY : FCKIT_EXCEPTION, FCKIT_EXCEPTION_HANDLER EXTERNAL :: ABOR1_EXCEPTION_HANDLER PROCEDURE(FCKIT_EXCEPTION_HANDLER), POINTER :: FUNPTR FUNPTR => ABOR1_EXCEPTION_HANDLER CALL FCKIT_EXCEPTION%SET_HANDLER( FUNPTR ) #endif END SUBROUTINE fiat-ecmwf-2.0.0/src/fiat/library/0000775000175000017500000000000015157200431017073 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/library/fiat_constructor.c0000664000175000017500000000224315157200431022630 0ustar alastairalastair/* * (C) Copyright 2022- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include #include #ifdef FIAT_ATTRIBUTE_CONSTRUCTOR_SUPPORTED #define ATTRIBUTE_CONSTRUCTOR __attribute__((constructor)) #else #define ATTRIBUTE_CONSTRUCTOR #endif // Forward declarations extern int ec_mpirank(); extern void tabort_delete_lockfile(); /* * fiat_debug() * * Access FIAT_DEBUG environment variable. Default treated as if FIAT_DEBUG=0 */ static int fiat_debug() { char* env = getenv("FIAT_DEBUG"); return env ? atoi(env) : 0; } /* * fiat_constructor() is called before main() upon loading of this library */ void ATTRIBUTE_CONSTRUCTOR fiat_constructor() { int mpi_rank = ec_mpirank(); if (mpi_rank == 0 && fiat_debug()) { fprintf(stderr,"FIAT_DEBUG fiat_constructor()\n"); } if( mpi_rank == 0 ) { tabort_delete_lockfile(); } } fiat-ecmwf-2.0.0/src/fiat/library/version.c.in0000664000175000017500000000251315157200431021332 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #define min(a, b) (((a) < (b)) ? (a) : (b)) #include #include //----------------------------------------------------------------------------- const char * fiat_version() { return "@fiat_VERSION@"; } const char * fiat_version_str() { return "@fiat_VERSION_STR@"; } unsigned int fiat_version_int() { return 10000*@fiat_VERSION_MAJOR@ + 100*@fiat_VERSION_MINOR@ + 1*@fiat_VERSION_PATCH@; } static char* __fiat_git_sha1 = 0; const char * fiat_git_sha1() { return "@fiat_GIT_SHA1@"; } const char * fiat_git_sha1_abbrev(unsigned int length) { size_t N = strlen(fiat_git_sha1())-40+length; N = min(strlen(fiat_git_sha1()),N); if( __fiat_git_sha1 ) free(__fiat_git_sha1); __fiat_git_sha1 = malloc( sizeof(char)*(N+1) ); memcpy( __fiat_git_sha1, fiat_git_sha1(), N ); __fiat_git_sha1[N] = '\0'; return __fiat_git_sha1; } //----------------------------------------------------------------------------- fiat-ecmwf-2.0.0/src/fiat/version.h0000664000175000017500000000127715157200431017274 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef fiat_version_h #define fiat_version_h #ifdef __cplusplus extern "C" { #endif const char * fiat_version(); unsigned int fiat_version_int(); const char * fiat_version_str(); const char * fiat_git_sha1(); const char * fiat_git_sha1_abbrev(unsigned int length); #ifdef __cplusplus } #endif #endif fiat-ecmwf-2.0.0/src/fiat/include/0000775000175000017500000000000015157200431017052 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/include/fiat/0000775000175000017500000000000015157200431017775 5ustar alastairalastairfiat-ecmwf-2.0.0/src/fiat/include/fiat/meminfo.intfb.h0000664000175000017500000000102615157200431022700 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE MEMINFO(KOUT,KSTEP) USE EC_PARKIND, ONLY : JPIM INTEGER(KIND=JPIM), INTENT(IN) :: KOUT, KSTEP END SUBROUTINE MEMINFO END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/mpl.h0000664000175000017500000000146615157200431020745 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* mpl.h */ #ifndef _MPL_H_ #define _MPL_H_ #ifdef __cplusplus extern "C" { #endif int mpl_init(); int mpl_end(); int mpl_myrank(); // Note return value is 1-based as opposed to MPI_Rank which is 0-based int mpl_comm(); int mpl_comm_oml(int oml_thread); // Note oml_thread argument is 1-based as opposed to omp_threads #ifdef __cplusplus } // extern "C" #endif #endif /* _MPL_H_ */ fiat-ecmwf-2.0.0/src/fiat/include/fiat/ec_meminfo.intfb.h0000664000175000017500000000122515157200431023350 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE EC_MEMINFO(KU,CDSTRING,KCOMM,KBARR,KIOTASK,KCALL) USE EC_PARKIND, ONLY : JPIM INTEGER(KIND=JPIM), INTENT(IN) :: KU,KCOMM,KBARR,KIOTASK,KCALL CHARACTER(LEN=*), INTENT(IN) :: CDSTRING END SUBROUTINE EC_MEMINFO END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/drhook.h0000664000175000017500000001432615157200431021442 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef _DRHOOK_H_ #define _DRHOOK_H_ #include "fiat_pp.h" #ifdef __cplusplus extern "C" { #endif #ifndef GNUC_BTRACE #define GNUC_BTRACE 128 #endif extern int drhook_lhook; /* drhook.c external interfaces */ extern void c_drhook_getenv_(const char *s, char *value, /* Hidden arguments */ int slen, const int valuelen); extern void c_drhook_memcounter_(const int *thread_id, const long long int *size, long long int *keyptr_addr); extern void c_drhook_raise_(const int *sig); extern void c_drhook_print_(const int *ftnunitno, const int *thread_id, const int *print_option, /* 1=raw call counts 2=calling tree 3=profiling info */ int *level); extern void c_drhook_init_signals_(const int *enforce); extern void c_drhook_set_lhook_(const int *lhook); extern void c_drhook_init_(const char *progname, const int *num_threads /* Hidden length */ ,int progname_len); extern void c_drhook_start_(const char *name, const int *thread_id, double *key, const char *filename, const int *sizeinfo /* Hidden length */ ,int name_len, int filename_len); extern void c_drhook_end_(const char *name, const int *thread_id, const double *key, const char *filename, const int *sizeinfo /* Hidden length */ ,int name_len, int filename_len); extern void c_drhook_watch_(const int *onoff, const char *array_name, const void *array_ptr, const int *nbytes, const int *abort_if_changed, const int *printkey, const int *nvals, const int *print_traceback_when_set /* Hidden length */ ,int array_name_len); extern void c_drhook_check_watch_(const char *where, const int *allow_abort /* Hidden length */ , int where_len); /* see dr_hook_prt.F90 for below */ extern void dr_hook_prt_logical_(const int *ftnunitno, const void *ptr, const int *nmax); extern void dr_hook_prt_char_(const int *ftnunitno, const void *ptr, const int *nmax); extern void dr_hook_prt_i4_(const int *ftnunitno, const void *ptr, const int *nmax); extern void dr_hook_prt_i8_(const int *ftnunitno, const void *ptr, const int *nmax); extern void dr_hook_prt_r4_(const int *ftnunitno, const void *ptr, const int *nmax); extern void dr_hook_prt_r8_(const int *ftnunitno, const void *ptr, const int *nmax); extern void ec_meminfo_(const int *KU, const char *CDSTRING, const int *KCOMM, const int *KBARR, const int *KIOTASK, const int *KCALL, int len_CDSTRING); /* see ec_meminfo.F90 */ /* see drhook.c */ extern const char *drhook_TIMESTR(int tid); extern const char *drhook_PREFIX(int tid); /**** C-interface to Dr.Hook ****/ extern void drhook_init(int argc, char *argv[]); extern int drhook_active( void ); extern void Dr_Hook(const char *name, int option, double *handle, const char *filename, int sizeinfo, int name_len, int filename_len); #define DRHOOK_START_RECUR(name,recur) \ static const char *drhook_name = #name; \ static const int drhook_name_len = sizeof(#name) - 1; /* Compile time eval */ \ static const char *drhook_filename = __FILE__; \ static const int drhook_filename_len = sizeof(__FILE__) - 1; /* Compile time eval */ \ double zhook_handle; \ if (!recur && drhook_lhook) Dr_Hook(drhook_name, 0, &zhook_handle, \ drhook_filename, 0, \ drhook_name_len, drhook_filename_len); { #define DRHOOK_START_BY_STRING_RECUR(name, recur) \ static const char *drhook_name = name; \ static const int drhook_name_len = sizeof(name) - 1; /* Compile time eval */ \ static const char *drhook_filename = __FILE__; \ static const int drhook_filename_len = sizeof(__FILE__) - 1; /* Compile time eval */ \ double zhook_handle; \ if (!recur && drhook_lhook) Dr_Hook(drhook_name, 0, &zhook_handle, \ drhook_filename, 0, \ drhook_name_len, drhook_filename_len); { #define DRHOOK_START_BY_STRING(name) DRHOOK_START_BY_STRING_RECUR(name,0) #define DRHOOK_RETURN_RECUR(sizeinfo,recur) \ if (!recur && drhook_lhook) Dr_Hook(drhook_name, 1, &zhook_handle, \ drhook_filename, sizeinfo, \ drhook_name_len, drhook_filename_len) #define DRHOOK_RETURN(sizeinfo) DRHOOK_RETURN_RECUR(sizeinfo,0) #define DRHOOK_END_RECUR(sizeinfo,recur) ; } DRHOOK_RETURN_RECUR(sizeinfo,recur) #define DRHOOK_END_DEFAULT() DRHOOK_END_RECUR(0,0) #define DRHOOK_END_SIZEINFO(sizeinfo) DRHOOK_END_RECUR(sizeinfo,0) #define DRHOOK_END( ... ) FIAT_PP_CAT( _DRHOOK_END_, FIAT_PP_VARIADIC_SIZE(__VA_ARGS__) )( __VA_ARGS__ ) // With 0 args --> DRHOOK_END_DEFAULT() // With 1 arg --> DRHOOK_END_SIZEINFO(sizeinfo) #define _DRHOOK_END_0 DRHOOK_END_DEFAULT #define _DRHOOK_END_1 DRHOOK_END_SIZEINFO #define DRHOOK_START(name) DRHOOK_START_RECUR(name,0) typedef void (*drhook_abort_t)(const char *file, int line, const char *text); extern void drhook_set_abort( drhook_abort_t ); extern void drhook_abort( const char *file, int line, const char *txt ); extern void drhook_calltree( void ); /* Fortran routines */ extern void dr_hook_prt_(const int *ftnunitno, const char *s /* Hidden arguments */ , int s_len); extern void c_dr_hook_procinfo(int *myproc, int *nproc, int *mpi_init); #ifdef __cplusplus } // extern "C" #endif #endif /* _DRHOOK_H_ */ fiat-ecmwf-2.0.0/src/fiat/include/fiat/ec_khz.intfb.h0000664000175000017500000000110315157200431022505 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE EC_KHZ(KOREID,KHZ) USE EC_PARKIND, ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KOREID INTEGER(KIND=JPIM),INTENT(OUT) :: KHZ END SUBROUTINE EC_KHZ END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/gstats_setup.intfb.h0000664000175000017500000000234715157200431024002 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE GSTATS_SETUP( KPROC,KMYPROC,KPRCIDS,& & LDSTATS,LDSTATSCPU,LDSYNCSTATS,LDDETAILED_STATS,LDBARRIER_STATS,LDBARRIER_STATS2,& & LDSTATS_OMP,LDSTATS_COMMS,LDSTATS_MEM,KSTATS_MEM,LDSTATS_ALLOC,& & LDTRACE_STATS,KTRACE_STATS,KPRNT_STATS,LDXML_STATS,LDCSV_STATS) USE EC_PARKIND, ONLY : JPIM LOGICAL :: LDSTATS LOGICAL :: LDSTATSCPU LOGICAL :: LDSYNCSTATS LOGICAL :: LDDETAILED_STATS LOGICAL :: LDBARRIER_STATS LOGICAL :: LDBARRIER_STATS2 LOGICAL :: LDSTATS_OMP LOGICAL :: LDSTATS_COMMS LOGICAL :: LDTRACE_STATS INTEGER(KIND=JPIM) :: KTRACE_STATS INTEGER(KIND=JPIM) :: KPROC,KMYPROC INTEGER(KIND=JPIM) :: KPRCIDS(KPROC) INTEGER(KIND=JPIM) :: KSTATS_MEM INTEGER(KIND=JPIM) :: KPRNT_STATS LOGICAL :: LDSTATS_MEM LOGICAL :: LDSTATS_ALLOC LOGICAL :: LDXML_STATS LOGICAL, OPTIONAL :: LDCSV_STATS END SUBROUTINE END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/abor1.h0000664000175000017500000000135515157200431021156 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* abor1.h */ #ifndef _ABOR1_H_ #define _ABOR1_H_ #ifdef __cplusplus extern "C" { #endif void abor1(const char* filename, const int linenum, const char* s); void set_abor1_exception_handler(); #define ABOR1(txt) abor1( __FILE__, __LINE__, (txt) ) #ifdef __cplusplus } // extern "C" #endif #endif /* _ABOR1_H_ */ fiat-ecmwf-2.0.0/src/fiat/include/fiat/ec_args.h0000664000175000017500000000274315157200431021557 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* ec_args.h * * Contains routines to store and retrieve command-line arguments as presented via C-main: "int main(int argc, char* argv[])" * A Fortran interface is available in ec_args_mod.F90 * The `ec_args(...)` routine should be called as early as possible * * Author: Sami Saarinen, ECMWF, 27-Apr-2006 * Modified: Willem Deconinck, ECMWF, 1-Jul-2021 * * An example C program: * * #include "ec_args.h" * int main( int argc, char* argv[] ) { * ec_args(argc,argv); * int num_args = ec_argc(); * const char* name = ec_argv()[0]; * } * */ #ifndef _EC_ARGS_H_ #define _EC_ARGS_H_ #if defined(__cplusplus) extern "C" { #endif /* Register command-line arguments as presented by C-main : "int main(int argc, char** argv)" */ void ec_args(int argc, char* argv[]); /* Return number of arguments, including the program-name, as presented by C-main */ int ec_argc(void); /* Return arguments (0-terminated), as presented by C-main */ const char* const* ec_argv(void); #if defined(__cplusplus) } // extern "C" #endif #endif /* _EC_ARGS_H_ */ fiat-ecmwf-2.0.0/src/fiat/include/fiat/fiat_pp.h0000664000175000017500000000505015157200431021570 0ustar alastairalastair/* * (C) Copyright 2021- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef FIAT_PREPROCESSOR_H #define FIAT_PREPROCESSOR_H #if __GNUC__ >= 7 #define FIAT_PP_FALLTHROUGH __attribute__((fallthrough)) #else #define FIAT_PP_FALLTHROUGH #endif #define FIAT_PP_CAT_(v1, v2) v1 ## v2 #define FIAT_PP_CAT(v1, v2) FIAT_PP_CAT_(v1, v2) #define FIAT_PP_CAT5_(_0, _1, _2, _3, _4) _0 ## _1 ## _2 ## _3 ## _4 #define FIAT_PP_IDENTITY_(x) x #define FIAT_PP_IDENTITY(x) FIAT_PP_IDENTITY_(x) #define FIAT_PP_VA_ARGS_(...) __VA_ARGS__ #define FIAT_PP_VA_ARGS(...) FIAT_PP_VA_ARGS_(__VA_ARGS__) #define FIAT_PP_IDENTITY_VA_ARGS_(x, ...) x, __VA_ARGS__ #define FIAT_PP_IDENTITY_VA_ARGS(x, ...) FIAT_PP_IDENTITY_VA_ARGS_(x, __VA_ARGS__) #define FIAT_PP_IIF_0(x, ...) __VA_ARGS__ #define FIAT_PP_IIF_1(x, ...) x #define FIAT_PP_IIF(c) FIAT_PP_CAT_(FIAT_PP_IIF_, c) #define FIAT_PP_HAS_COMMA(...) FIAT_PP_IDENTITY(FIAT_PP_VA_ARGS_TAIL(__VA_ARGS__, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0)) #define FIAT_PP_IS_EMPTY_TRIGGER_PARENTHESIS_(...) , #define FIAT_PP_IS_EMPTY(...) FIAT_PP_IS_EMPTY_( \ /* test if there is just one argument, eventually an empty one */ \ FIAT_PP_HAS_COMMA(__VA_ARGS__), \ /* test if _TRIGGER_PARENTHESIS_ together with the argument adds a comma */ \ FIAT_PP_HAS_COMMA(FIAT_PP_IS_EMPTY_TRIGGER_PARENTHESIS_ __VA_ARGS__), \ /* test if the argument together with a parenthesis adds a comma */ \ FIAT_PP_HAS_COMMA(__VA_ARGS__ ()), \ /* test if placing it between _TRIGGER_PARENTHESIS_ and the parenthesis adds a comma */ \ FIAT_PP_HAS_COMMA(FIAT_PP_IS_EMPTY_TRIGGER_PARENTHESIS_ __VA_ARGS__ ())) #define FIAT_PP_IS_EMPTY_(_0, _1, _2, _3) FIAT_PP_HAS_COMMA(FIAT_PP_CAT5_(FIAT_PP_IS_EMPTY_IS_EMPTY_CASE_, _0, _1, _2, _3)) #define FIAT_PP_IS_EMPTY_IS_EMPTY_CASE_0001 , #define FIAT_PP_VARIADIC_SIZE(...) FIAT_PP_IIF(FIAT_PP_IS_EMPTY(__VA_ARGS__))(0, FIAT_PP_VARIADIC_SIZE_(__VA_ARGS__, FIAT_PP_VA_ARGS_SEQ16())) #define FIAT_PP_VARIADIC_SIZE_(...) FIAT_PP_IDENTITY(FIAT_PP_VA_ARGS_TAIL(__VA_ARGS__)) #define FIAT_PP_VA_ARGS_TAIL(_0,_1,_2,_3,_4,_5,_6,_7,_8,_9,_10,_11,_12,_13,_14, x, ...) x #define FIAT_PP_VA_ARGS_SEQ16() 15,14,13,12,11,10,9,8,7,6,5,4,3,2,1,0 #endif fiat-ecmwf-2.0.0/src/fiat/include/fiat/abor1.intfb.h0000664000175000017500000000163115157200431022254 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE ABOR1(CDTEXT) CHARACTER(LEN=*), INTENT(IN) :: CDTEXT END SUBROUTINE ABOR1 SUBROUTINE ABOR1FL(CDFILE, KLINENUM, CDTEXT) USE EC_PARKIND ,ONLY : JPIM CHARACTER(LEN=*), INTENT(IN) :: CDFILE,CDTEXT INTEGER(KIND=JPIM), INTENT(IN) :: KLINENUM END SUBROUTINE ABOR1FL SUBROUTINE ABOR1_EXCEPTION_HANDLER() END SUBROUTINE ABOR1_EXCEPTION_HANDLER SUBROUTINE SET_ABOR1_EXCEPTION_HANDLER() BIND(C,name="set_abor1_exception_handler") END SUBROUTINE SET_ABOR1_EXCEPTION_HANDLER END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/oml.h0000664000175000017500000000262315157200431020740 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * (C) Copyright 2013- Meteo-France. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ /* oml.h */ #ifndef _OML_H_ #define _OML_H_ #ifdef __cplusplus extern "C" { #endif typedef long long int oml_lock_t; /* i.e. 64-bit integer */ typedef void (*oml_function_t)(void*); int oml_get_thread_num(); // Equivalent to omp_get_thread_num() int oml_my_thread(); // Equivalent to omp_get_thread_num() + 1 int oml_get_max_threads(); // Equivalent to omp_get_max_threads() int oml_get_num_threads(); // Equivalent to omp_get_num_threads() int oml_in_parallel(); void oml_set_debug(int); int oml_get_debug(); void oml_init_lock(); void oml_destroy_lock(); void oml_init_lockid(oml_lock_t*); void oml_init_lockid_with_name(oml_lock_t*, const char* name); void oml_set_lock(); void oml_set_lockid(oml_lock_t*); void oml_unset_lock(); void oml_unset_lockid(oml_lock_t*); int oml_test_lock(); int oml_test_lockid(oml_lock_t*); void oml_run_parallel(oml_function_t function, void* args); void oml_barrier(); #ifdef __cplusplus } // extern "C" #endif #endif /* _OML_H_ */ fiat-ecmwf-2.0.0/src/fiat/include/fiat/user_clock.intfb.h0000664000175000017500000000373015157200431023403 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE USER_CLOCK(PELAPSED_TIME,PELAPSED_TIME_SINCE,PVECTOR_CP,PTOTAL_CP) !**** *USER_CLOCK* - interface to system dependent timer routines ! Purpose. ! -------- ! Returns elapsed and CP from the start of execution. ! Elapsed time is made relative to the first call to USER_CLOCK. !** Interface. ! ---------- ! ZTIME=USER_CLOCK(PELAPSED_TIME,PELAPSED_TIME_SINCE, ! PVECTOR_CP,PTOTAL_CP) ! Explicit arguments: (All are optional arguments) ! PELAPSED_TIME=wall clock time (seconds) ! PELAPSED_TIME_SINCE=wall clock time (seconds) ! change from input value of this parameter ! PVECTOR_CP=CP vector time (seconds) ! PTOTAL_CP=total CP time (seconds) ! Author. ! ------- ! D.Dent *ECMWF* ! External References: ! ------------------- ! TIMEF,CPTIME ! Modifications. ! -------------- ! Original : 97-09-25 ! F. Vana 05-Mar-2015 Support for single precision ! ---------------------------------------------------------- USE EC_PARKIND ,ONLY : JPRD, JPIM IMPLICIT NONE REAL(KIND=JPRD),INTENT(OUT) :: PELAPSED_TIME,PVECTOR_CP,PTOTAL_CP REAL(KIND=JPRD),INTENT(INOUT) :: PELAPSED_TIME_SINCE OPTIONAL PELAPSED_TIME,PELAPSED_TIME_SINCE OPTIONAL PVECTOR_CP,PTOTAL_CP REAL(KIND=JPRD) :: ZVECTOR_CP,ZTOTAL_CP,ZWALL REAL(KIND=JPRD),EXTERNAL :: TIMEF END SUBROUTINE USER_CLOCK END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/ec_pmon.intfb.h0000664000175000017500000000107515157200431022672 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! (C) Copyright 2013- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! INTERFACE SUBROUTINE EC_PMON(ENERGY,POWER) USE EC_PARKIND, ONLY : JPIB INTEGER(KIND=JPIB),INTENT(OUT) :: ENERGY,POWER END SUBROUTINE EC_PMON END INTERFACE fiat-ecmwf-2.0.0/src/fiat/include/fiat/ec_get_cycles.h0000664000175000017500000000106515157200431022740 0ustar alastairalastair/* * (C) Copyright 2005- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #ifndef EC_GET_CYCLES_H #define EC_GET_CYCLES_H #ifdef __cplusplus extern "C" { #endif long long int ec_get_cycles(); #ifdef __cplusplus } // extern "C" #endif #endif fiat-ecmwf-2.0.0/src/fiat/include/fiat/ec_checksum.h0000664000175000017500000000100215157200431022410 0ustar alastairalastair#ifndef EC_CHECKSUM_H #define EC_CHECKSUM_H #ifdef __cplusplus extern "C" { #endif #include #include typedef int32_t ec_checksum_fletcher16_t; uint16_t ec_checksum_fletcher16(const void* data, size_t bytes); void ec_checksum_fletcher16_reset(ec_checksum_fletcher16_t*); void ec_checksum_fletcher16_update(ec_checksum_fletcher16_t*, const void* data, size_t bytes); uint16_t ec_checksum_fletcher16_digest(const ec_checksum_fletcher16_t*); #ifdef __cplusplus } // extern "C" #endif #endiffiat-ecmwf-2.0.0/src/fiat/CMakeLists.txt0000664000175000017500000002000315157200431020162 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # (C) Copyright 2024- Meteo-France. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. ### Assemble list of definitions if( HAVE_FCKIT ) list( APPEND FIAT_DEFINITIONS WITH_FCKIT ) endif() if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") list( APPEND FIAT_DEFINITIONS LINUX ) endif() if( HAVE_DR_HOOK_MULTI_PRECISION_HANDLES ) list( APPEND FIAT_DEFINITIONS DR_HOOK_MULTI_PRECISION_HANDLES ) endif() if( FIAT_ATTRIBUTE_CONSTRUCTOR_SUPPORTED ) list( APPEND FIAT_DEFINITIONS FIAT_ATTRIBUTE_CONSTRUCTOR_SUPPORTED ) endif() ### Compilation flags if( CMAKE_Fortran_COMPILER_ID MATCHES "Intel" ) ## To disable checking of argument correctness of dummy mpi symbols ecbuild_add_fortran_flags( -warn nointerfaces NO_FAIL ) endif() if( CMAKE_Fortran_COMPILER_ID MATCHES "GNU" ) ecbuild_add_fortran_flags( -ffree-line-length-none NO_FAIL ) if( CMAKE_Fortran_COMPILER_VERSION GREATER_EQUAL 10 ) ecbuild_add_fortran_flags( -fallow-argument-mismatch NO_FAIL ) endif() endif() if( NOT fiat_VERSION_PATCH ) set( fiat_VERSION_PATCH 0 ) endif() configure_file( ${CMAKE_CURRENT_SOURCE_DIR}/library/version.c.in ${CMAKE_CURRENT_BINARY_DIR}/version.c @ONLY ) ecbuild_list_add_pattern( LIST fiat_src GLOB drhook/*.c drhook/*.F* ecsort/*.c ecsort/*.F* gstats/*.F* library/*.c oml/*.F* system/*.c system/*.F* system/*.cc util/*.c util/*.F* ) if( HAVE_MPL_F77_DEPRECATED) ecbuild_list_add_pattern( LIST fiat_src GLOB "mpl/internal_deprecated/*.c" "mpl/internal_deprecated/*.F*" "mpl/mpl_module.F90" "mpl/mpl_bindc.F90" ) ecbuild_info( "FIAT building with *deprecated* F77 (mpif.h) MPL interface" ) else() ecbuild_list_add_pattern( LIST fiat_src GLOB "mpl/internal_f08/*.c" "mpl/internal_f08/*.F*" "mpl/mpl_module.F90" "mpl/mpl_bindc.F90" ) if( HAVE_MPI ) ecbuild_info( "Not compiling mpi_f08_dummy_mod, because MPI is found" ) ecbuild_list_exclude_pattern( LIST fiat_src REGEX mpl/internal_f08/mpi_f08_dummy_mod.F90 ) endif() ecbuild_info( "FIAT building with MPI_F08 MPL interface" ) endif() ecbuild_list_exclude_pattern( LIST fiat_src REGEX drhook/extensions/*) set( fiat_src ${fiat_src} PARENT_SCOPE ) if( HAVE_MPI ) set( FIAT_MPI_LIBRARIES MPI::MPI_Fortran ) else() set( FIAT_MPI_LIBRARIES ${MPI_SERIAL_LIBRARIES} ) endif() # work around problem when linking privately to MPI libraries with NVHPC # (see https://github.com/ecmwf-ifs/fiat/pull/79) # NOTE matching change required in fiat-import.cmake.in to ensure # that downstream packages link to MPI::MPI_Fortran dependency. set(LINK_FIAT_MPI_LIBRARIES PRIVATE_LIBS ${FIAT_MPI_LIBRARIES}) if (CMAKE_Fortran_COMPILER_ID MATCHES "NVHPC|IntelLLVM") set(LINK_FIAT_MPI_LIBRARIES PUBLIC_LIBS ${FIAT_MPI_LIBRARIES}) endif() set( fiatlib_SHARED fiat) set( fiatlib_STATIC fiat) set( FIAT_DEPENDENCE_STATIC ) set( FIAT_DEPENDENCE_SHARED ) if( ${BUILD_SHARED_LIBS} MATCHES "BOTH" ) set( LIB_TYPES SHARED STATIC ) set( fiatlib_STATIC fiat-static) set( FIAT_DEPENDENCE_STATIC ${fiatlib_SHARED} ) elseif( BUILD_SHARED_LIBS ) set( LIB_TYPES SHARED ) else() set( LIB_TYPES STATIC ) endif() foreach( LIB_TYPE ${LIB_TYPES} ) set( fiatlib ${fiatlib_${LIB_TYPE}} ) ecbuild_add_library( TARGET ${fiatlib} LINKER_LANGUAGE Fortran SOURCES ${fiat_src} ${CMAKE_CURRENT_BINARY_DIR}/version.c TYPE ${LIB_TYPE} PRIVATE_LIBS ${CMAKE_DL_LIBS} ${RT_LIB} ${LINK_FIAT_MPI_LIBRARIES} PRIVATE_INCLUDES ${CMAKE_CURRENT_SOURCE_DIR}/drhook/internal ${CMAKE_CURRENT_SOURCE_DIR}/ecsort/internal ${CMAKE_CURRENT_SOURCE_DIR}/util/internal ${CMAKE_CURRENT_SOURCE_DIR}/system/internal PUBLIC_INCLUDES $ $ $ $ $ ${MPI_Fortran_INCLUDE_DIRS} OUTPUT_NAME fiat DEPENDS ${FIAT_DEPENDENCE_${LIB_TYPE}} ) if (HAVE_DR_HOOK_NVTX) # Files from within DrHook ecbuild_list_add_pattern( LIST fiat_nvtx_src GLOB *.c SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR}/drhook/extensions/nvtx) target_sources(${fiatlib} PRIVATE ${fiat_nvtx_src}) target_include_directories(${fiatlib} PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/drhook/extensions/nvtx) target_compile_definitions(${fiatlib} PRIVATE DR_HOOK_HAVE_NVTX=1 HAVE_NVTX3=${HAVE_NVTX3} ) # Link with NVTX target_link_libraries (${fiatlib} PRIVATE ${NVTX_LIBRARIES}) target_include_directories(${fiatlib} PRIVATE ${NVTX_INCLUDE_DIRS}) endif() if (HAVE_DR_HOOK_ROCTX) # Files from within DrHook ecbuild_list_add_pattern( LIST fiat_roctx_src GLOB *.c SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR}/drhook/extensions/roctx) target_sources(fiat PRIVATE ${fiat_roctx_src}) target_include_directories(${fiatlib} PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/drhook/extensions/roctx) target_compile_definitions(${fiatlib} PRIVATE DR_HOOK_HAVE_ROCTX=1 HAVE_ROCPROFILER_SDK_ROCTX=${HAVE_ROCPROFILER_SDK_ROCTX}) # Link with ROCTX target_link_libraries (${fiatlib} PRIVATE ${ROCTX_LIBRARIES}) target_include_directories(${fiatlib} PRIVATE ${ROCTX_INCLUDE_DIRS}) endif() if (HAVE_DR_HOOK_PAPI) # Files from within DrHook ecbuild_list_add_pattern( LIST fiat_papi_src GLOB *.c SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR}/drhook/extensions/papi) target_sources(${fiatlib} PRIVATE ${fiat_papi_src}) target_include_directories(${fiatlib} PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/drhook/extensions/papi) target_compile_definitions(${fiatlib} PRIVATE DR_HOOK_HAVE_PAPI=1) # Files defined externally target_link_libraries ( ${fiatlib} PRIVATE ${PAPI_LIBRARIES} ) target_include_directories ( ${fiatlib} PRIVATE ${PAPI_INCLUDE_DIRS} ) endif() if( ${CMAKE_SYSTEM_NAME} MATCHES "Darwin" ) # Following should not be necessary; # Probably a bug in the M1 prerelease of gfortran 10.2.0.4 target_compile_definitions( ${fiatlib} PRIVATE $<$:__APPLE__>) endif() if( NOT HAVE_MPI ) # define a preprocessor macro to improve messaging in dr_hook_init target_compile_definitions( ${fiatlib} PRIVATE NO_MPI_SUPPORT) endif() if( HAVE_MPL_F77_DEPRECATED) target_compile_definitions( ${fiatlib} PRIVATE MPL_F77_DEPRECATED ) endif() if( HAVE_MPL_CHECK_CONTIG) target_compile_definitions( ${fiatlib} PRIVATE MPL_CHECK_CONTIG ) endif() target_compile_definitions( ${fiatlib} PRIVATE ${FIAT_DEFINITIONS} ) if( HAVE_FCKIT ) target_link_libraries( ${fiatlib} PRIVATE fckit ) endif() if( HAVE_OMP ) target_link_libraries( ${fiatlib} PRIVATE OpenMP::OpenMP_Fortran ) endif() fiat_target_ignore_missing_symbols( TARGET ${fiatlib} SYMBOLS _MallocExtension_GetNumericProperty _MPI_Get_version _MPI_Get_library_version ) fiat_target_fortran_module_directory( TARGET ${fiatlib} MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/fiat INSTALL_DIRECTORY module/fiat ) endforeach() ## Install and Export ## execute_process( COMMAND ${CMAKE_COMMAND} -E make_directory ${PROJECT_BINARY_DIR}/include ) execute_process( COMMAND ${CMAKE_COMMAND} -E create_symlink ${CMAKE_CURRENT_SOURCE_DIR}/include/fiat ${PROJECT_BINARY_DIR}/include/fiat ) install( DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/include/fiat DESTINATION include ) install( FILES ${CMAKE_CURRENT_SOURCE_DIR}/version.h DESTINATION include/fiat ) set( FIAT_DEFINITIONS ${FIAT_DEFINITIONS} PARENT_SCOPE ) fiat-ecmwf-2.0.0/src/programs/0000775000175000017500000000000015157200431016336 5ustar alastairalastairfiat-ecmwf-2.0.0/src/programs/drhook-merge0000775000175000017500000000026515157200431020652 0ustar alastairalastair#!/usr/bin/env bash SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" PREFIX=${SCRIPT_DIR}/.. cat "$@" | perl -w ${PREFIX}/share/fiat/drhook/drhook_merge_walltime.pl fiat-ecmwf-2.0.0/src/programs/fiat.in0000775000175000017500000000512215157200431017614 0ustar alastairalastair#!/usr/bin/env bash # (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. FIAT_VERSION_STR="@fiat_VERSION_STR@" FIAT_VERSION="@fiat_VERSION@" FIAT_GIT_SHA1="@fiat_GIT_SHA1@" ################################################################# # Commands ################################################################# usage() { echo "Usage: fiat [--version] [--info] [--git]" exit $1 } version() { echo "${FIAT_VERSION_STR}" } append_git() { if (( $# > b )); then git="$@" echo ", git-sha1 ${git::${#git}-33}" fi } info() { echo "fiat version (${FIAT_VERSION_STR})$(append_git ${FIAT_GIT_SHA1})" echo "" echo "Build:" echo " build type : @CMAKE_BUILD_TYPE@" echo " timestamp : @EC_BUILD_TIMESTAMP@" echo " op. system : @CMAKE_SYSTEM@ (@EC_OS_NAME@.@EC_OS_BITS@)" echo " processor : @CMAKE_SYSTEM_PROCESSOR@" echo " c compiler : @CMAKE_C_COMPILER_ID@ @CMAKE_C_COMPILER_VERSION@" echo " flags : @EC_C_FLAGS@" echo " fortran compiler: @CMAKE_Fortran_COMPILER_ID@ @CMAKE_Fortran_COMPILER_VERSION@" echo " flags : @EC_Fortran_FLAGS@" echo "" echo "Features:" echo " MPI : @fiat_HAVE_MPI@@MPL_BACKEND@" echo " OMP : @fiat_HAVE_OMP@" echo " FCKIT : @fiat_HAVE_FCKIT@" echo "" echo "Dependencies: " if [[ @fiat_HAVE_FCKIT@ -eq "1" ]]; then echo " fckit version (@fckit_VERSION@)$(append_git @fckit_GIT_SHA1@)" fi } gitsha1() { echo "${FIAT_GIT_SHA1}" } ################################################################# # Parse command-line ################################################################# if test $# -eq 0; then usage 1 fi while test $# -gt 0; do # Split --option=value in $opt="--option" and $val="value" opt="" val="" case "$1" in --*=*) opt=`echo "$1" | sed 's/=.*//'` val=`echo "$1" | sed 's/--[_a-zA-Z0-9]*=//'` ;; --*) opt=$1 ;; *) break ;; esac # Parse options case "$opt" in --version) version ;; --git) gitsha1 ;; --info) info ;; --) shift break ;; *) echo "unknown option: $opt" usage 1 ;; esac shift done fiat-ecmwf-2.0.0/src/programs/fiat-printbinding.c0000664000175000017500000001067415157200431022122 0ustar alastairalastair/* * (C) Copyright 2021- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #define _GNU_SOURCE #include #include #include #include #include #include #include #ifndef NOMPI #include #else #warning Not compiled with MPI support #endif #ifdef _OPENMP #include #else #warning Not compiled with OpenMP support int omp_get_max_threads(void) { return 1; } int omp_get_thread_num(void) { return 0; } #endif #if defined(__APPLE__) // These variables and functions are Linux specific typedef struct cpu_set_t cpu_set_t; struct cpu_set_t {}; static int CPU_ISSET(int index, const cpu_set_t* cpu_set) { return 0; } static void CPU_ZERO(cpu_set_t* cpu_set) {} static int sched_getaffinity(pid_t pid, size_t size, cpu_set_t* cpu_set) { return 0; } #endif #define maxprocs 256 #define maxthreads 256 void printbind( int rank, int nthreads, int counts[maxthreads], int procs[maxprocs][maxthreads], char hostname[100] ) { /* Print out the binding for one rank */ int thread, proc ; printf("Rank %4d on %16s has %3d threads on cores: ",rank, hostname, nthreads); for(thread=0;threadprocs[proc][thread]+1) { printf("%d",procs[proc][thread]); } } } printf(")"); } printf("\n"); return; } int main( int argc , char **argv ) { int rank,size,cpu; int i,np,tid,counts[maxthreads]; cpu_set_t myset; int myprocs[maxprocs][maxthreads]; int nthreads; char hostname[100]; #ifndef NOMPI MPI_Init(&argc, &argv); MPI_Comm_size(MPI_COMM_WORLD,&size); MPI_Comm_rank(MPI_COMM_WORLD,&rank); #endif gethostname(hostname,99); nthreads=omp_get_max_threads(); /* Create list of procs for this rank & thread */ #pragma omp parallel default(none) private(myset, np, i, tid) shared(rank, myprocs, counts) { /* Each thread creates a list of cores that it is bound to */ tid=omp_get_thread_num(); np=sysconf(_SC_NPROCESSORS_ONLN); /* Initialise */ counts[tid]=0; CPU_ZERO(&myset); for(i=0; i $ ) ## Install and Export ## install(DIRECTORY DESTINATION "include/mpi_serial") if( ${HAVE_DUMMY_MPI_HEADER} ) install( FILES ${CMAKE_CURRENT_SOURCE_DIR}/mpif.h DESTINATION include/mpi_serial ) endif() fiat-ecmwf-2.0.0/src/mpi_serial/mpi_end.F0000664000175000017500000000074515157200431020360 0ustar alastairalastairC (C) Copyright 2005- ECMWF. C (C) Copyright 2013- Meteo-France. C C This software is licensed under the terms of the Apache Licence Version 2.0 C which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. C In applying this licence, ECMWF does not waive the privileges and immunities C granted to it by virtue of its status as an intergovernmental organisation C nor does it submit to any jurisdiction. C subroutine mpi_end(ierr) ierr=0 return end fiat-ecmwf-2.0.0/src/CMakeLists.txt0000664000175000017500000000147515157200431017253 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. add_subdirectory( mpi_serial ) add_subdirectory( fiat ) add_subdirectory( parkind ) add_subdirectory( programs ) foreach( filepath ${fiat_src} parkind1.F90 parkind2.F90 ) get_filename_component( filename ${filepath} NAME ) list( APPEND fiat_SOURCE_FILENAMES ${filename} ) endforeach() set( fiat_SOURCE_FILENAMES ${fiat_SOURCE_FILENAMES} PARENT_SCOPE ) # needs to be available for tests set( FIAT_DEFINITIONS ${FIAT_DEFINITIONS} PARENT_SCOPE ) fiat-ecmwf-2.0.0/share/0000775000175000017500000000000015157200431015017 5ustar alastairalastairfiat-ecmwf-2.0.0/share/fiat/0000775000175000017500000000000015157200431015742 5ustar alastairalastairfiat-ecmwf-2.0.0/share/fiat/drhook/0000775000175000017500000000000015157200431017230 5ustar alastairalastairfiat-ecmwf-2.0.0/share/fiat/drhook/drhook_merge_walltime_max.pl0000664000175000017500000001554215157200431025004 0ustar alastairalastair# # drhook_merge_walltime.pl # # For merging wall clock time results from different MPI-tasks # i.e. DR_HOOK_OPT=prof # # Original script by Eckhard Tschirschnitz, Cray, 2006 (Mflop/s) # # Usage: cat drhook.* | perl -w drhook_merge_walltime_max.pl # # (sorts w.r.t max-value, not average) # use strict; # this expects concatenated dr_hook listings (wall clock time listings) my $bignum = 999999999; my $skip = 1; #my $threshold = 1.0; my $threshold = 0.001; my $tottim = 0; my $maxwall = 0; my $minwall = $bignum; my $avgwall = 0; my $stdevwall = 0; my $nproc = 0; # no of MPI-tasks my $omp = 0; # max. no of OpenMP-threads encountered my $exe = ""; # the name of the executable my %namelist = (); my %sumself = (); my %sum2self = (); my %maxself = (); my %minself = (); my %ompself = (); my %numcalls = (); for (<>) { chomp; # get rid of the newline character next if (m/^\s*$/); # a blank line if (m/^\s*Profiling\b/) { if ($nproc == 0) { $exe = $1 if (m/program='([^\'].*)'/); } $nproc++; $skip = 1; next; # for (<>) } elsif (m/^\s+Wall-time\s+is\s+(\S+)\s+/) { my $value = $1; $maxwall = $value if ($value > $maxwall); $minwall = $value if ($value < $minwall); $avgwall += $value; $stdevwall += $value * $value; next; # for (<>) } elsif (m/^\s+1\s+/) { foreach my $name (keys %ompself) { my $self = $ompself{$name}; $sumself{$name} += $self; $sum2self{$name} += $self * $self; $maxself{$name} = $self if ($self > $maxself{$name}); $minself{$name} = $self if ($self < $minself{$name}); $tottim += $self; } %ompself = (); $skip = 0; } if ($skip == 0) { # rank %time cumul self total #_of_calls self:ms/call tot:ms/call routine_name if (m/^\s+\S+\s+\S+\s+\S+\s+(\S+)\s+\S+\s+(\S+)\s+\S+\s+\S+\s+(.*)/) { my $self = $1; my $ncalls = $2; my $name = $3; my $tid = 0; $name =~ s/\s+//g; $name =~ s/^[*]//; #print "$self $name\n"; if ($name =~ m/^(.*)[@](\d+)/) { $tid = $2; $omp = $tid if ($tid > $omp); $name = $1; } $namelist{$name} = $name if (!defined($namelist{$name})); if (!defined($sumself{$name})) { $sumself{$name} = 0; $sum2self{$name} = 0; $maxself{$name} = 0; $minself{$name} = $bignum; $numcalls{$name} = 0.0; } $numcalls{$name} += $ncalls; # Account the most expensive OpenMP thread only $ompself{$name} = 0 if (!defined($ompself{$name})); $ompself{$name} = $self if ($self > $ompself{$name}); } } } if ($nproc > 0) { # One final time ... foreach my $name (keys %ompself) { my $self = $ompself{$name}; $sumself{$name} += $self; $sum2self{$name} += $self * $self; $maxself{$name} = $self if ($self > $maxself{$name}); $minself{$name} = $self if ($self < $minself{$name}); $tottim += $self; } print STDOUT "Name of the executable : $exe\n"; print STDOUT "Number of MPI-tasks : $nproc\n"; print STDOUT "Number of OpenMP-threads : $omp\n"; # printf ("Total time : %.3f secs (sum over all MPI-tasks; only max OpenMP-time accounted for)\n", $tottim); $avgwall /= $nproc; if ($nproc > 1) { $stdevwall = ($stdevwall - $nproc * $avgwall * $avgwall)/($nproc - 1); $stdevwall = ($stdevwall > 0) ? sqrt($stdevwall) : 0; # be careful with rounding of errors } else { $stdevwall = 0; } printf STDOUT ("Wall-times over all MPI-tasks (secs) : Min=%.3f, Max=%.3f, Avg=%.3f, StDev=%.3f\n", $minwall, $maxwall, $avgwall, $stdevwall); printf ("Routines whose total time (i.e. sum) > %.3f secs will be included in the listing\n",$threshold); printf STDOUT ("%7s %10s %10s %10s %8s %8s %12s : %s\n", "Avg-%", "Avg.time", "Min.time", "Max.time", "St.dev", "Imbal-%", "# of calls", "Name of the routine"); # open(PIPE,"|sort -nr|sed 's/ %/%/'"); # sorts w.r.t average percentage (commented ayt) open(PIPE,"|sort -nr +4|sed 's/ %/%/'"); # sorts w.r.t. max column# (column number starts from 0, not 1 in unix sort) # Values accounted for my $acc_avgpercent = 0; my $acc_avgtime = 0; my $acc_maxtime = 0; my $acc_mintime = $bignum; foreach my $name (keys %sumself) { my $value = $sumself{$name}; if ($value > $threshold) { my $percent = $value/$tottim*100; my $aveself = $value/$nproc; my $stdev = 0; if ($nproc > 1) { $stdev = $sum2self{$name}; $stdev = ($stdev - $nproc * $aveself * $aveself)/($nproc - 1); $stdev = ($stdev > 0) ? sqrt($stdev) : 0; # be careful with rounding of errors } printf PIPE ("%6.2f %% %10.3f %10.3f %10.3f %8.3f %7.2f%% %12.0f : %s\n", $percent, $aveself, $minself{$name},$maxself{$name},$stdev, ($maxself{$name} - $minself{$name})/$maxself{$name}*100, $numcalls{$name}, $name); # Update values accounted for $acc_avgpercent += $percent; $acc_avgtime += $aveself; $acc_mintime = $minself{$name} if ($acc_mintime > $minself{$name}); $acc_maxtime = $maxself{$name} if ($acc_maxtime < $maxself{$name}); } } close(PIPE); printf STDOUT ("%6.2f%% %10.3f %10.3f %10.3f\n", $acc_avgpercent,$acc_avgtime, $acc_mintime, $acc_maxtime); } # A sample of typical output __DATA__ Name of the executable : /fdb/mpm/RAPS9/fdb/eqgp/bin/ifsMASTER Number of MPI-tasks : 64 Number of OpenMP-threads : 4 Wall-times over all MPI-tasks (secs) : Min=990.460, Max=1009.730, Avg=997.713, StDev=3.809 Routines whose total time (i.e. sum) > 1.000 secs will be included in the listing Avg-% Avg.time Min.time Max.time St.dev Imbal-% # of calls : Name of the routine 4.63% 46.190 2.728 47.549 5.537 94.26% 1664 : >MPL-SCATTER_CTLVEC(524) 3.22% 32.117 31.618 32.832 0.300 3.70% 1253376 : LWPTL 3.10% 30.895 30.554 31.394 0.199 2.68% 1253376 : SWNIAD 3.04% 30.287 29.697 31.075 0.287 4.43% 1253376 : LWPAD 2.04% 20.350 7.867 21.129 1.933 62.77% 3034240 : BROADCREAL 1.73% 17.288 17.098 17.562 0.088 2.64% 753223680 : SWDE 1.73% 17.262 10.546 27.521 2.945 61.68% 158400 : >MPL-SLCOMM1_COMMS(509) 1.61% 16.103 11.131 22.163 3.132 49.78% 316544 : >MPL-SLCOMM2A_COMMS(512) 1.52% 15.172 14.947 15.551 0.120 3.88% 1253376 : SWNITL 1.45% 14.488 0.024 16.144 2.017 99.85% 140544 : >MPL-IRCVGPF(527) 1.45% 14.428 13.744 15.056 0.307 8.71% 2506752 : LWAI 1.44% 14.383 13.958 15.184 0.297 8.07% 300810240 : SWDEAD 1.43% 14.317 14.163 14.502 0.068 2.34% 300810240 : SWDETL 1.36% 13.553 13.129 14.112 0.257 6.97% 6266880 : LAITRITLAD 1.30% 12.980 6.884 15.539 1.590 55.70% 922794098 : CUADJTQ 1.29% 12.909 12.566 13.452 0.178 6.59% 2506752 : SWRAD fiat-ecmwf-2.0.0/share/fiat/drhook/drhook_merge_walltime.pl0000664000175000017500000001521215157200431024131 0ustar alastairalastair# # drhook_merge_walltime.pl # # For merging wall clock time results from different MPI-tasks # i.e. DR_HOOK_OPT=prof # # Original script by Eckhard Tschirschnitz, Cray, 2006 (Mflop/s) # # Usage: cat drhook.* | perl -w drhook_merge_walltime.pl # use strict; # this expects concatenated dr_hook listings (wall clock time listings) my $bignum = 999999999; my $skip = 1; #my $threshold = 1.0; my $threshold = 0.001; my $tottim = 0; my $maxwall = 0; my $minwall = $bignum; my $avgwall = 0; my $stdevwall = 0; my $nproc = 0; # no of MPI-tasks my $omp = 0; # max. no of OpenMP-threads encountered my $exe = ""; # the name of the executable my %namelist = (); my %sumself = (); my %sum2self = (); my %maxself = (); my %minself = (); my %ompself = (); my %numcalls = (); for (<>) { chomp; # get rid of the newline character next if (m/^\s*$/); # a blank line if (m/^\s*Profiling\b/) { if ($nproc == 0) { $exe = $1 if (m/program='([^\'].*)'/); } $nproc++; $skip = 1; next; # for (<>) } elsif (m/^\s+Wall-time\s+is\s+(\S+)\s+/) { my $value = $1; $maxwall = $value if ($value > $maxwall); $minwall = $value if ($value < $minwall); $avgwall += $value; $stdevwall += $value * $value; next; # for (<>) } elsif (m/^\s+1\s+/) { foreach my $name (keys %ompself) { my $self = $ompself{$name}; $sumself{$name} += $self; $sum2self{$name} += $self * $self; $maxself{$name} = $self if ($self > $maxself{$name}); $minself{$name} = $self if ($self < $minself{$name}); $tottim += $self; } %ompself = (); $skip = 0; } if ($skip == 0) { # rank %time cumul self total #_of_calls self:ms/call tot:ms/call routine_name if (m/^\s+\S+\s+\S+\s+\S+\s+(\S+)\s+\S+\s+(\S+)\s+\S+\s+\S+\s+(.*)/) { my $self = $1; my $ncalls = $2; my $name = $3; my $tid = 0; $name =~ s/\s+//g; $name =~ s/^[*]//; #print "$self $name\n"; if ($name =~ m/^(.*)[@](\d+)/) { $tid = $2; $omp = $tid if ($tid > $omp); $name = $1; } $namelist{$name} = $name if (!defined($namelist{$name})); if (!defined($sumself{$name})) { $sumself{$name} = 0; $sum2self{$name} = 0; $maxself{$name} = 0; $minself{$name} = $bignum; $numcalls{$name} = 0.0; } $numcalls{$name} += $ncalls; # Account the most expensive OpenMP thread only $ompself{$name} = 0 if (!defined($ompself{$name})); $ompself{$name} = $self if ($self > $ompself{$name}); } } } if ($nproc > 0) { # One final time ... foreach my $name (keys %ompself) { my $self = $ompself{$name}; $sumself{$name} += $self; $sum2self{$name} += $self * $self; $maxself{$name} = $self if ($self > $maxself{$name}); $minself{$name} = $self if ($self < $minself{$name}); $tottim += $self; } print STDOUT "Name of the executable : $exe\n"; print STDOUT "Number of MPI-tasks : $nproc\n"; print STDOUT "Number of OpenMP-threads : $omp\n"; # printf ("Total time : %.3f secs (sum over all MPI-tasks; only max OpenMP-time accounted for)\n", $tottim); $avgwall /= $nproc; if ($nproc > 1) { $stdevwall = ($stdevwall - $nproc * $avgwall * $avgwall)/($nproc - 1); $stdevwall = ($stdevwall > 0) ? sqrt($stdevwall) : 0; # be careful with rounding of errors } else { $stdevwall = 0; } printf STDOUT ("Wall-times over all MPI-tasks (secs) : Min=%.3f, Max=%.3f, Avg=%.3f, StDev=%.3f\n", $minwall, $maxwall, $avgwall, $stdevwall); printf ("Routines whose total time (i.e. sum) > %.3f secs will be included in the listing\n",$threshold); printf STDOUT ("%7s %10s %10s %10s %8s %8s %12s : %s\n", "Avg-%", "Avg.time", "Min.time", "Max.time", "St.dev", "Imbal-%", "# of calls", "Name of the routine"); open(PIPE,"|sort -nr|sed 's/ %/%/'"); # Values accounted for my $acc_avgpercent = 0; my $acc_avgtime = 0; my $acc_maxtime = 0; my $acc_mintime = $bignum; foreach my $name (keys %sumself) { my $value = $sumself{$name}; if ($value > $threshold) { my $percent = $value/$tottim*100; my $aveself = $value/$nproc; my $stdev = 0; if ($nproc > 1) { $stdev = $sum2self{$name}; $stdev = ($stdev - $nproc * $aveself * $aveself)/($nproc - 1); $stdev = ($stdev > 0) ? sqrt($stdev) : 0; # be careful with rounding of errors } printf PIPE ("%6.2f %% %10.3f %10.3f %10.3f %8.3f %7.2f%% %12.0f : %s\n", $percent, $aveself, $minself{$name},$maxself{$name},$stdev, ($maxself{$name} - $minself{$name})/$maxself{$name}*100, $numcalls{$name}, $name); # Update values accounted for $acc_avgpercent += $percent; $acc_avgtime += $aveself; $acc_mintime = $minself{$name} if ($acc_mintime > $minself{$name}); $acc_maxtime = $maxself{$name} if ($acc_maxtime < $maxself{$name}); } } close(PIPE); printf STDOUT ("%6.2f%% %10.3f %10.3f %10.3f\n", $acc_avgpercent,$acc_avgtime, $acc_mintime, $acc_maxtime); } # A sample of typical output __DATA__ Name of the executable : /fdb/mpm/RAPS9/fdb/eqgp/bin/ifsMASTER Number of MPI-tasks : 64 Number of OpenMP-threads : 4 Wall-times over all MPI-tasks (secs) : Min=990.460, Max=1009.730, Avg=997.713, StDev=3.809 Routines whose total time (i.e. sum) > 1.000 secs will be included in the listing Avg-% Avg.time Min.time Max.time St.dev Imbal-% # of calls : Name of the routine 4.63% 46.190 2.728 47.549 5.537 94.26% 1664 : >MPL-SCATTER_CTLVEC(524) 3.22% 32.117 31.618 32.832 0.300 3.70% 1253376 : LWPTL 3.10% 30.895 30.554 31.394 0.199 2.68% 1253376 : SWNIAD 3.04% 30.287 29.697 31.075 0.287 4.43% 1253376 : LWPAD 2.04% 20.350 7.867 21.129 1.933 62.77% 3034240 : BROADCREAL 1.73% 17.288 17.098 17.562 0.088 2.64% 753223680 : SWDE 1.73% 17.262 10.546 27.521 2.945 61.68% 158400 : >MPL-SLCOMM1_COMMS(509) 1.61% 16.103 11.131 22.163 3.132 49.78% 316544 : >MPL-SLCOMM2A_COMMS(512) 1.52% 15.172 14.947 15.551 0.120 3.88% 1253376 : SWNITL 1.45% 14.488 0.024 16.144 2.017 99.85% 140544 : >MPL-IRCVGPF(527) 1.45% 14.428 13.744 15.056 0.307 8.71% 2506752 : LWAI 1.44% 14.383 13.958 15.184 0.297 8.07% 300810240 : SWDEAD 1.43% 14.317 14.163 14.502 0.068 2.34% 300810240 : SWDETL 1.36% 13.553 13.129 14.112 0.257 6.97% 6266880 : LAITRITLAD 1.30% 12.980 6.884 15.539 1.590 55.70% 922794098 : CUADJTQ 1.29% 12.909 12.566 13.452 0.178 6.59% 2506752 : SWRAD fiat-ecmwf-2.0.0/share/fiat/drhook/drhook_merge_walltime_total_max.pl0000664000175000017500000001566215157200431026212 0ustar alastairalastair# # drhook_merge_walltime.pl # # For merging wall clock time results from different MPI-tasks # i.e. DR_HOOK_OPT=prof # # Original script by Eckhard Tschirschnitz, Cray, 2006 (Mflop/s) # # Usage: cat drhook.* | perl -w drhook_merge_walltime_total_max.pl # # (sorts w.r.t max-value, not average) # use strict; # this expects concatenated dr_hook listings (wall clock time listings) # note below: self in fact denotes self + children times i.e. total time my $bignum = 999999999; my $skip = 1; #my $threshold = 1.0; my $threshold = 0.001; my $tottim = 0; my $maxwall = 0; my $minwall = $bignum; my $avgwall = 0; my $stdevwall = 0; my $nproc = 0; # no of MPI-tasks my $omp = 0; # max. no of OpenMP-threads encountered my $exe = ""; # the name of the executable my %namelist = (); my %sumself = (); my %sum2self = (); my %maxself = (); my %minself = (); my %ompself = (); my %numcalls = (); for (<>) { chomp; # get rid of the newline character next if (m/^\s*$/); # a blank line if (m/^\s*Profiling\b/) { if ($nproc == 0) { $exe = $1 if (m/program='([^\'].*)'/); } $nproc++; $skip = 1; next; # for (<>) } elsif (m/^\s+Wall-time\s+is\s+(\S+)\s+/) { my $value = $1; $maxwall = $value if ($value > $maxwall); $minwall = $value if ($value < $minwall); $avgwall += $value; $stdevwall += $value * $value; next; # for (<>) } elsif (m/^\s+1\s+/) { foreach my $name (keys %ompself) { my $self = $ompself{$name}; $sumself{$name} += $self; $sum2self{$name} += $self * $self; $maxself{$name} = $self if ($self > $maxself{$name}); $minself{$name} = $self if ($self < $minself{$name}); $tottim += $self; } %ompself = (); $skip = 0; } if ($skip == 0) { # rank %time cumul self total #_of_calls self:ms/call tot:ms/call routine_name if (m/^\s+\S+\s+\S+\s+\S+\s+\S+\s+(\S+)\s+(\S+)\s+\S+\s+\S+\s+(.*)/) { my $self = $1; my $ncalls = $2; my $name = $3; my $tid = 0; $name =~ s/\s+//g; $name =~ s/^[*]//; #print "$self $name\n"; if ($name =~ m/^(.*)[@](\d+)/) { $tid = $2; $omp = $tid if ($tid > $omp); $name = $1; } $namelist{$name} = $name if (!defined($namelist{$name})); if (!defined($sumself{$name})) { $sumself{$name} = 0; $sum2self{$name} = 0; $maxself{$name} = 0; $minself{$name} = $bignum; $numcalls{$name} = 0.0; } $numcalls{$name} += $ncalls; # Account the most expensive OpenMP thread only $ompself{$name} = 0 if (!defined($ompself{$name})); $ompself{$name} = $self if ($self > $ompself{$name}); } } } if ($nproc > 0) { # One final time ... foreach my $name (keys %ompself) { my $self = $ompself{$name}; $sumself{$name} += $self; $sum2self{$name} += $self * $self; $maxself{$name} = $self if ($self > $maxself{$name}); $minself{$name} = $self if ($self < $minself{$name}); $tottim += $self; } print STDOUT "Name of the executable : $exe\n"; print STDOUT "Number of MPI-tasks : $nproc\n"; print STDOUT "Number of OpenMP-threads : $omp\n"; # printf ("Total time : %.3f secs (sum over all MPI-tasks; only max OpenMP-time accounted for)\n", $tottim); $avgwall /= $nproc; if ($nproc > 1) { $stdevwall = ($stdevwall - $nproc * $avgwall * $avgwall)/($nproc - 1); $stdevwall = ($stdevwall > 0) ? sqrt($stdevwall) : 0; # be careful with rounding of errors } else { $stdevwall = 0; } printf STDOUT ("Wall-times over all MPI-tasks (secs) : Min=%.3f, Max=%.3f, Avg=%.3f, StDev=%.3f\n", $minwall, $maxwall, $avgwall, $stdevwall); printf ("Routines whose total time (i.e. sum) > %.3f secs will be included in the listing\n",$threshold); printf STDOUT ("%7s %10s %10s %10s %8s %8s %12s : %s\n", "Avg-%", "Avg.time", "Min.time", "Max.time", "St.dev", "Imbal-%", "# of calls", "Name of the routine"); # open(PIPE,"|sort -nr|sed 's/ %/%/'"); # sorts w.r.t average percentage (commented ayt) open(PIPE,"|sort -nr +4|sed 's/ %/%/'"); # sorts w.r.t. max column# (column number starts from 0, not 1 in unix sort) # Values accounted for my $acc_avgpercent = 0; my $acc_avgtime = 0; my $acc_maxtime = 0; my $acc_mintime = $bignum; foreach my $name (keys %sumself) { my $value = $sumself{$name}; if ($value > $threshold) { my $percent = $value/$tottim*100; my $aveself = $value/$nproc; my $stdev = 0; if ($nproc > 1) { $stdev = $sum2self{$name}; $stdev = ($stdev - $nproc * $aveself * $aveself)/($nproc - 1); $stdev = ($stdev > 0) ? sqrt($stdev) : 0; # be careful with rounding of errors } printf PIPE ("%6.2f %% %10.3f %10.3f %10.3f %8.3f %7.2f%% %12.0f : %s\n", $percent, $aveself, $minself{$name},$maxself{$name},$stdev, ($maxself{$name} - $minself{$name})/$maxself{$name}*100, $numcalls{$name}, $name); # Update values accounted for $acc_avgpercent += $percent; $acc_avgtime += $aveself; $acc_mintime = $minself{$name} if ($acc_mintime > $minself{$name}); $acc_maxtime = $maxself{$name} if ($acc_maxtime < $maxself{$name}); } } close(PIPE); printf STDOUT ("%6.2f%% %10.3f %10.3f %10.3f\n", $acc_avgpercent,$acc_avgtime, $acc_mintime, $acc_maxtime); } # A sample of typical output __DATA__ Name of the executable : /fdb/mpm/RAPS9/fdb/eqgp/bin/ifsMASTER Number of MPI-tasks : 64 Number of OpenMP-threads : 4 Wall-times over all MPI-tasks (secs) : Min=990.460, Max=1009.730, Avg=997.713, StDev=3.809 Routines whose total time (i.e. sum) > 1.000 secs will be included in the listing Avg-% Avg.time Min.time Max.time St.dev Imbal-% # of calls : Name of the routine 4.63% 46.190 2.728 47.549 5.537 94.26% 1664 : >MPL-SCATTER_CTLVEC(524) 3.22% 32.117 31.618 32.832 0.300 3.70% 1253376 : LWPTL 3.10% 30.895 30.554 31.394 0.199 2.68% 1253376 : SWNIAD 3.04% 30.287 29.697 31.075 0.287 4.43% 1253376 : LWPAD 2.04% 20.350 7.867 21.129 1.933 62.77% 3034240 : BROADCREAL 1.73% 17.288 17.098 17.562 0.088 2.64% 753223680 : SWDE 1.73% 17.262 10.546 27.521 2.945 61.68% 158400 : >MPL-SLCOMM1_COMMS(509) 1.61% 16.103 11.131 22.163 3.132 49.78% 316544 : >MPL-SLCOMM2A_COMMS(512) 1.52% 15.172 14.947 15.551 0.120 3.88% 1253376 : SWNITL 1.45% 14.488 0.024 16.144 2.017 99.85% 140544 : >MPL-IRCVGPF(527) 1.45% 14.428 13.744 15.056 0.307 8.71% 2506752 : LWAI 1.44% 14.383 13.958 15.184 0.297 8.07% 300810240 : SWDEAD 1.43% 14.317 14.163 14.502 0.068 2.34% 300810240 : SWDETL 1.36% 13.553 13.129 14.112 0.257 6.97% 6266880 : LAITRITLAD 1.30% 12.980 6.884 15.539 1.590 55.70% 922794098 : CUADJTQ 1.29% 12.909 12.566 13.452 0.178 6.59% 2506752 : SWRAD fiat-ecmwf-2.0.0/share/fiat/drhook/CMakeLists.txt0000664000175000017500000000102115157200431021762 0ustar alastairalastairlist( APPEND files drhook_merge_walltime.pl drhook_merge_walltime_max.pl drhook_merge_walltime_total_max.pl ) set( destination share/fiat/drhook ) install( FILES ${files} DESTINATION ${destination} PERMISSIONS OWNER_READ GROUP_READ WORLD_READ) file(MAKE_DIRECTORY ${CMAKE_BINARY_DIR}/${destination}) foreach( file ${files} ) execute_process(COMMAND "${CMAKE_COMMAND}" "-E" "create_symlink" "${CMAKE_CURRENT_SOURCE_DIR}/${file}" "${CMAKE_BINARY_DIR}/${destination}/${file}") endforeach() fiat-ecmwf-2.0.0/share/fiat/CMakeLists.txt0000664000175000017500000000003215157200431020475 0ustar alastairalastairadd_subdirectory(drhook) fiat-ecmwf-2.0.0/share/CMakeLists.txt0000664000175000017500000000003015157200431017550 0ustar alastairalastairadd_subdirectory(fiat) fiat-ecmwf-2.0.0/README.md0000664000175000017500000000556115157200431015203 0ustar alastairalastairFIAT **** The Fortran IFS and Arpege Toolkit Introduction ============ FIAT is a collection of selected Fortran utility libraries, extracted from the IFS/Arpege model. - drhook : tracing - gstats : timing - parkind : choose precision - mpl : MPI communication - mpi_serial: MPI dummy symbols compiled into static library - other various routines License ======= FIAT is distributed under the Apache License Version 2.0. See `LICENSE` file for details. Installing FIAT =============== Supported Platforms ------------------- - Linux - Apple MacOS Other UNIX-like operating systems may work too out of the box. Requirements ------------ - Fortran and C compiler, and optionally C++ compiler - CMake (see https://cmake.org) - ecbuild (see https://github.com/ecmwf/ecbuild) Further optional dependencies: - MPI Fortran libraries, preferably with MPI F08 support - fckit compiled with eckit support (see https://github.com/ecmwf/fckit) Building FIAT ------------- Environment variables $ export ecbuild_ROOT= $ export MPI_HOME= $ export fckit_ROOT= $ export CC= $ export FC= $ export CXX= You must compile FIAT out-of-source, so create a build-directory $ mkdir build && cd build Configuration of the build happens through standard CMake $ cmake .. Extra options can be added to the `cmake` command to control the build: - `-DCMAKE_BUILD_TYPE=` default=RelWithDebInfo (typically `-O2 -g`) - `-DENABLE_TESTS=` - `-DENABLE_SINGLE_PRECISION=` default=ON - `-DENABLE_DOUBLE_PRECISION=` default=ON - `-DENABLE_MPI=` # if OFF, MPL links against dummy mpi_serial library - `-DENABLE_OMP=` - `-DENABLE_MPL_F77_DEPRECATED=` default=OFF # build F77-based MPL instead of MPI_F08-based MPL - `-DENABLE_MPL_CHECK_CONTIG=` default=OFF # enable run-time checks of contiguous status of arrays passed to MPL - `-DENABLE_DUMMY_MPI_HEADER=` default=ON - `-DCMAKE_INSTALL_PREFIX=` More options to control compilation flags, only when defaults are not sufficient - `-DOpenMP_Fortran_FLAGS=` - `-DCMAKE_Fortran_FLAGS=` - `-DCMAKE_C_FLAGS=` Once this has finished successfully, run ``make`` and ``make install``. Optionally, tests can be run to check succesful compilation, when the feature TESTS is enabled (`-DENABLE_TESTS=ON`, default ON) $ ctest Contributing ============ Contributions to fiat are welcome. In order to do so, please open an issue where a feature request or bug can be discussed. Then create a pull request with your contribution and sign the [contributors license agreement (CLA)](https://bol-claassistant.ecmwf.int/ecmwf-ifs/fiat). fiat-ecmwf-2.0.0/.gitignore0000664000175000017500000000001015157200431015674 0ustar alastairalastair.vscode fiat-ecmwf-2.0.0/LICENSE0000664000175000017500000002500315157200431014722 0ustar alastairalastair Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS Copyright 1996-2018 ECMWF Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. fiat-ecmwf-2.0.0/cmake/0000775000175000017500000000000015157200431014775 5ustar alastairalastairfiat-ecmwf-2.0.0/cmake/FindNVTX.cmake0000664000175000017500000000424315157200431017402 0ustar alastairalastair# (C) Copyright 2024- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # Used to switch between NVTX3 and nvToolsExt set(HAVE_NVTX3 0) set(NVTX_REQUIRED_VARIABLES NVTX_LIBRARIES) # Despite FindCUDAToolkit being added in 3.17, it doesn't seem to work # on ECMWF's HPC. It seems to be a bug as this is resolved in 3.20. # So less than 3.20 requires manual searching if( ${CMAKE_VERSION} VERSION_LESS "3.20" ) find_path(NVTX_ROOT NAMES include/nvToolsExt.h HINTS ENV NVTX_ROOT CUDA_ROOT ENV CUDA_ROOT ENV NVHPC_CUDA_HOME ENV CUDA_DIR) find_library(NVTX_LIBRARIES NAMES nvToolsExt HINTS ${NVTX_ROOT} PATH_SUFFIXES lib lib64) find_path(NVTX_INCLUDE_DIRS NAMES nvToolsExt.h HINTS ${NVTX_ROOT}/include) list(APPEND NVTX_REQUIRED_VARIABLES NVTX_INCLUDE_DIRS) # nvToolsExt has been deprecated since CMake version 3.25 elseif( ${CMAKE_VERSION} VERSION_LESS "3.25" ) find_package(CUDAToolkit COMPONENTS CUDA::nvToolsExt) if (TARGET CUDA::nvToolsExt) set(NVTX_LIBRARIES CUDA::nvToolsExt) endif() # Preferred, most up to date method else() # CMake 3.25+ defines the NVTX3 target find_package(CUDAToolkit COMPONENTS CUDA::nvtx3) # While we've guaranteed CMake supports the NVTX3 target, the CUDA # version needs to be 10.0+ to actually implement it if( TARGET CUDA::nvtx3 ) set(NVTX_LIBRARIES CUDA::nvtx3) set(HAVE_NVTX3 1) # Else fallback to searching for the older nvToolsExt. # If this also fails, `find_package_handle_standard_args` will tell the user else() find_package(CUDAToolkit COMPONENTS CUDA::nvToolsExt) if (TARGET CUDA::nvToolsExt) set(NVTX_LIBRARIES CUDA::nvToolsExt) endif() endif() endif() include(FindPackageHandleStandardArgs) find_package_handle_standard_args(NVTX REQUIRED_VARS ${NVTX_REQUIRED_VARIABLES}) fiat-ecmwf-2.0.0/cmake/FindRealtime.cmake0000664000175000017500000000156715157200431020353 0ustar alastairalastair# (C) Copyright 2011- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. #Sets: # RT_LIB = the library to link against if( DEFINED REALTIME_PATH ) find_library(RT_LIB rt PATHS ${REALTIME_PATH}/lib NO_DEFAULT_PATH ) endif() find_library( RT_LIB rt ) mark_as_advanced( RT_LIB ) include(FindPackageHandleStandardArgs) # Handle the QUIET and REQUIRED arguments and set REALTIME_FOUND to TRUE # if all listed variables are TRUE # Note: capitalisation of the package name must be the same as in the file name find_package_handle_standard_args(Realtime DEFAULT_MSG RT_LIB ) fiat-ecmwf-2.0.0/cmake/fiat_target_ignore_missing_symbols.cmake0000664000175000017500000000167015157200431025140 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. # Define function to ignore missing symbols (lazy linking) function( fiat_target_ignore_missing_symbols ) set( options ) set( single_value_args TARGET ) set( multi_value_args SYMBOLS ) cmake_parse_arguments( _PAR "${options}" "${single_value_args}" "${multi_value_args}" ${_FIRST_ARG} ${ARGN} ) if( ${CMAKE_SYSTEM_NAME} MATCHES "Darwin" ) unset( link_lazy ) foreach(symbol ${_PAR_SYMBOLS} ) set(link_lazy "${link_lazy} -Wl,-U,${symbol}") endforeach() set_target_properties( ${_PAR_TARGET} PROPERTIES LINK_FLAGS "${link_lazy}" ) endif() endfunction() fiat-ecmwf-2.0.0/cmake/FindPAPI.cmake0000664000175000017500000000212015157200431017324 0ustar alastairalastair# Try to find PAPI headers and libraries. # # Usage of this module as follows: # # find_package(PAPI) # # Variables used by this module, they can change the default behaviour and need # to be set before calling find_package: # # PAPI_ROOT Set this variable to the root installation of # libpapi if the module has problems finding the # proper installation path. # # Variables defined by this module: # # PAPI_FOUND System has PAPI libraries and headers # PAPI_LIBRARIES The PAPI library # PAPI_INCLUDE_DIRS The location of PAPI headers find_path(PAPI_ROOT NAMES include/papi.h ) find_library(PAPI_LIBRARIES # Pick the static library first for easier run-time linking. NAMES libpapi.so libpapi.a papi HINTS ${PAPI_ROOT}/lib ) find_path(PAPI_INCLUDE_DIRS NAMES papi.h HINTS ${PAPI_ROOT}/include ) include(FindPackageHandleStandardArgs) find_package_handle_standard_args(PAPI DEFAULT_MSG PAPI_LIBRARIES PAPI_INCLUDE_DIRS ) mark_as_advanced( PAPI_LIBRARIES PAPI_INCLUDE_DIRS ) fiat-ecmwf-2.0.0/cmake/fiat-import.cmake.in0000664000175000017500000000615015157200431020641 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. ################################################################## ## Project dependencies include( CMakeFindDependencyMacro ) set( fiat_VERSION_STR @fiat_VERSION_STR@ ) set( fiat_HAVE_MPI @fiat_HAVE_MPI@ ) set( fiat_HAVE_OMP @fiat_HAVE_OMP@ ) set( fiat_HAVE_FCKIT @fiat_HAVE_FCKIT@ ) set( fiat_HAVE_DR_HOOK_NVTX @fiat_HAVE_DR_HOOK_NVTX@ ) set( fiat_HAVE_DR_HOOK_ROCTX @fiat_HAVE_DR_HOOK_ROCTX@ ) set( fiat_HAVE_DR_HOOK_PAPI @fiat_HAVE_DR_HOOK_PAPI@ ) set( fiat_HAVE_SINGLE_PRECISION @fiat_HAVE_SINGLE_PRECISION@ ) set( fiat_HAVE_DOUBLE_PRECISION @fiat_HAVE_DOUBLE_PRECISION@ ) set( fiat_HAVE_MPL_F08 @fiat_HAVE_MPL_F08@ ) set( fiat_REQUIRES_PRIVATE_DEPENDENCIES @fiat_REQUIRES_PRIVATE_DEPENDENCIES@ ) set( fiat_SOURCE_FILENAMES @fiat_SOURCE_FILENAMES@ ) if( fiat_HAVE_OMP AND NOT TARGET OpenMP::OpenMP_Fortran ) if( NOT CMAKE_Fortran_COMPILER_LOADED ) enable_language( Fortran ) endif() find_dependency( OpenMP COMPONENTS Fortran ) endif() # Workaround NVHPC linking issue (see https://github.com/ecmwf-ifs/fiat/pull/79) if( fiat_HAVE_MPI AND NOT TARGET MPI::MPI_Fortran ) if( NOT CMAKE_Fortran_COMPILER_LOADED ) enable_language( Fortran ) endif() if (CMAKE_Fortran_COMPILER_ID MATCHES "NVHPC|IntelLLVM" OR fiat_REQUIRES_PRIVATE_DEPENDENCIES) find_dependency( MPI COMPONENTS Fortran ) endif() endif() if (fiat_REQUIRES_PRIVATE_DEPENDENCIES) set(BACKUP_CMAKE_MODULE_PATH "${CMAKE_MODULE_PATH}") list(APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR}) if( fiat_HAVE_DR_HOOK_NVTX ) find_dependency( NVTX ) endif() if( fiat_HAVE_DR_HOOK_ROCTX ) find_dependency( ROCTX ) endif() if( fiat_HAVE_DR_HOOK_PAPI ) find_dependency( PAPI ) endif() set(CMAKE_MODULE_PATH ${BACKUP_CMAKE_MODULE_PATH}) endif() if( fiat_HAVE_FCKIT AND NOT TARGET fckit ) find_dependency( fckit HINTS ${CMAKE_CURRENT_LIST_DIR}/../fckit @fckit_DIR@ ) endif() if( ${CMAKE_SYSTEM_NAME} MATCHES "Darwin") set(_whole_archive "-Wl,-force_load") set(_no_whole_archive "") else() set(_whole_archive "-Wl,--whole-archive") set(_no_whole_archive "-Wl,--no-whole-archive") endif() set(MPI_SERIAL_LIBRARIES ${_whole_archive} mpi_serial ${_no_whole_archive}) ################################################################## ## Handle components set( ${CMAKE_FIND_PACKAGE_NAME}_single_FOUND ${fiat_HAVE_SINGLE_PRECISION} ) set( ${CMAKE_FIND_PACKAGE_NAME}_double_FOUND ${fiat_HAVE_DOUBLE_PRECISION} ) foreach( _component ${${CMAKE_FIND_PACKAGE_NAME}_FIND_COMPONENTS} ) if( NOT ${CMAKE_FIND_PACKAGE_NAME}_${_component}_FOUND AND ${CMAKE_FIND_PACKAGE_NAME}_FIND_REQUIRED ) message( SEND_ERROR "fiat was not build with support for COMPONENT ${_component}" ) endif() endforeach() fiat-ecmwf-2.0.0/cmake/fiat_macros.cmake0000664000175000017500000000370215157200431020270 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. ### Workaround to extract GIT_SHA1 from parent directory if( NOT ${PROJECT_NAME}_GIT_SHA1 ) get_filename_component( PARENT_DIR ${PROJECT_SOURCE_DIR} DIRECTORY ) if( EXISTS ${PARENT_DIR}/.git ) get_filename_component( PARENT_REPOSITORY_NAME ${PARENT_DIR} NAME_WE ) get_git_head_revision( GIT_REFSPEC ${PROJECT_NAME}_GIT_SHA1 ) string( SUBSTRING "${${PROJECT_NAME}_GIT_SHA1}" 0 7 ${PROJECT_NAME}_GIT_SHA1_SHORT ) set( ${PROJECT_NAME}_GIT_SHA1_SHORT "${PARENT_REPOSITORY_NAME}/${${PROJECT_NAME}_GIT_SHA1_SHORT}" ) set( ${PROJECT_NAME}_GIT_SHA1 "${PARENT_REPOSITORY_NAME}/${${PROJECT_NAME}_GIT_SHA1}" ) endif() endif() try_run( execute_result compile_result ${CMAKE_CURRENT_BINARY_DIR} ${PROJECT_SOURCE_DIR}/cmake/test_attribute_constructor.c COMPILE_OUTPUT_VARIABLE compile_output RUN_OUTPUT_VARIABLE execute_output ) ecbuild_debug("Compiling and running ${PROJECT_SOURCE_DIR}/cmake/test_attribute_constructor.c") ecbuild_debug_var( compile_result ) ecbuild_debug_var( compile_output ) ecbuild_debug_var( execute_result ) ecbuild_debug_var( execute_output ) if( NOT DEFINED FIAT_ATTRIBUTE_CONSTRUCTOR_SUPPORTED ) set( FIAT_ATTRIBUTE_CONSTRUCTOR_SUPPORTED 0 ) if( compile_result ) if( execute_result MATCHES 0 ) set( FIAT_ATTRIBUTE_CONSTRUCTOR_SUPPORTED 1 ) else() ecbuild_info("Compiler failed to correctly run program with \"__attribute__((constructor))\".") endif() endif() endif() include( fiat_target_fortran_module_directory ) include( fiat_target_ignore_missing_symbols ) fiat-ecmwf-2.0.0/cmake/fiat_compiler_warnings.cmake0000664000175000017500000000211715157200431022525 0ustar alastairalastair # Activate warnings, ecbuild macros check the compiler recognises the options if(HAVE_WARNINGS) ecbuild_add_c_flags("-Wall" NO_FAIL) ecbuild_add_c_flags("-Wextra" NO_FAIL) ecbuild_add_c_flags("-Wno-unused-parameter" NO_FAIL) ecbuild_add_c_flags("-Wno-unused-variable" NO_FAIL) ecbuild_add_c_flags("-Wno-gnu-zero-variadic-macro-arguments" NO_FAIL) endif() # Always disable some warnings ecbuild_add_c_flags("-Wno-deprecated-declarations" NO_FAIL) if( CMAKE_C_COMPILER_ID MATCHES Intel ) ecbuild_add_c_flags("-diag-disable=279") # controlling expression is constant ecbuild_add_c_flags("-diag-disable=11076") # inline limits endif() if( CMAKE_Fortran_COMPILER_ID MATCHES Cray ) ecbuild_add_fortran_flags("-hnomessage=878") # A module named ... has already been directly or indirectly use associated into this scope ecbuild_add_fortran_flags("-hnomessage=867") # Module ... has no public objects declared in the module, therefore nothing can be use associated from the module. endif() fiat-ecmwf-2.0.0/cmake/project_summary.cmake0000664000175000017500000000344715157200431021232 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. ecbuild_info( "Build type : [${CMAKE_BUILD_TYPE}]" ) set( Fortran_flags_str "Fortran flags" ) set( C_flags_str "C flags " ) set( CXX_flags_str "C++ flags " ) string( TOUPPER ${PROJECT_NAME} PNAME ) foreach( lang Fortran C CXX ) set( flags "${CMAKE_${lang}_FLAGS} ${CMAKE_${lang}_FLAGS_${CMAKE_BUILD_TYPE_CAPS}} ${${PNAME}_${lang}_FLAGS} ${${PNAME}_${lang}_FLAGS_${CMAKE_BUILD_TYPE_CAPS}}" ) string(REGEX REPLACE "[ ]+" " " flags ${flags}) string(STRIP "${flags}" flags) ecbuild_info( "${${lang}_flags_str} : [${flags}]" ) endforeach() ecbuild_info( "OpenMP (following variable can be overwritten by user)" ) ecbuild_info( " OpenMP_Fortran_FLAGS : [${OpenMP_Fortran_FLAGS}]" ) ecbuild_info( "MPI (export MPI_HOME to correct MPI implementation)" ) ecbuild_info( " MPI_Fortran_INCLUDE_DIRS : [${MPI_Fortran_INCLUDE_DIRS}]" ) ecbuild_info( " MPI_Fortran_LIBRARIES : [${MPI_Fortran_LIBRARIES}]" ) ecbuild_info( " MPIEXEC : [${MPIEXEC}]" ) if( HAVE_DR_HOOK_NVTX ) ecbuild_info( "NVTX_LIBRARIES : [${NVTX_LIBRARIES}]" ) endif() if( HAVE_DR_HOOK_ROCTX ) ecbuild_info( "ROCTX" ) ecbuild_info( " ROCTX_LIBRARIES : [${ROCTX_LIBRARIES}]" ) ecbuild_info( " ROCTX_INCLUDE_DIRS : [${ROCTX_INCLUDE_DIRS}]" ) endif() ecbuild_info( "---------------------------------------------------------" ) fiat-ecmwf-2.0.0/cmake/test_attribute_constructor.c0000664000175000017500000000124215157200431022647 0ustar alastairalastair/* * (C) Copyright 2022- ECMWF. * * This software is licensed under the terms of the Apache Licence Version 2.0 * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. * In applying this licence, ECMWF does not waive the privileges and immunities * granted to it by virtue of its status as an intergovernmental organisation * nor does it submit to any jurisdiction. */ #include static int constructor_called = 0; void __attribute__((constructor)) constructor() { printf("constructor()\n"); constructor_called = 1; } int main() { printf("main()\n"); if (constructor_called) { return 0; // success } return 1; // error } fiat-ecmwf-2.0.0/cmake/FindROCTX.cmake0000664000175000017500000000321315157200431017476 0ustar alastairalastair# (C) Copyright 2024- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. set( HAVE_ROCPROFILER_SDK_ROCTX 0) set( ROCTX_REQUIRED_VARS ROCTX_LIBRARIES ) if ( NOT DEFINED ROCM_PATH OR NOT ROCM_PATH_FOUND ) find_path( ROCM_PATH NAMES include/roctracer/roctx.h include/rocprofiler-sdk-roctx/roctx.h HINTS ENV ROCM_DIR ENV ROCM_PATH ENV HIP_PATH ENV ROCM_ROOT_DIR /opt/rocm ) endif() find_package( rocprofiler-sdk-roctx CONFIG PATHS ${ROCM_PATH}/lib ${ROCM_PATH}/lib/cmake ) if( NOT rocprofiler-sdk-roctx_FOUND ) find_path( ROCTX_INCLUDE_DIRS NAMES roctx.h HINTS ${ROCM_PATH}/include/roctracer/ ${ROCM_PATH}/include/rocprofiler-sdk-roctx ) list( APPEND ROCTX_REQUIRED_VARS ROCTX_INCLUDE_DIRS ) find_path( ROCTX_LIBRARY_PATH NAMES libroctx64.so HINTS ${ROCM_PATH}/lib/ ) if ( ROCTX_LIBRARY_PATH ) set( ROCTX_LIBRARIES ${ROCTX_LIBRARY_PATH}/libroctx64.so ) endif() else() if( TARGET ${rocprofiler-sdk-roctx_LIBRARIES} ) set( ROCTX_LIBRARIES ${rocprofiler-sdk-roctx_LIBRARIES} ) set( ROCTX_INCLUDE_DIRS ${rocprofiler-sdk-roctx_INCLUDE_DIR} ) list( APPEND ROCTX_REQUIRED_VARS ROCTX_INCLUDE_DIRS ) set( HAVE_ROCPROFILER_SDK_ROCTX 1 ) endif() endif() include( FindPackageHandleStandardArgs ) find_package_handle_standard_args( ROCTX REQUIRED_VARS ${ROCTX_REQUIRED_VARS} ) fiat-ecmwf-2.0.0/cmake/fiat_target_fortran_module_directory.cmake0000664000175000017500000000303215157200431025452 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. macro( fiat_target_fortran_module_directory ) set( options NO_MODULE_DIRECTORY ) set( single_value_args TARGET MODULE_DIRECTORY INSTALL_DIRECTORY ) set( multi_value_args "" ) cmake_parse_arguments( _PAR "${options}" "${single_value_args}" "${multi_value_args}" ${_FIRST_ARG} ${ARGN} ) if( NOT _PAR_TARGET ) ecbuild_critical( "Missing argument TARGET" ) endif() if( _PAR_NO_MODULE_DIRECTORY ) set_target_properties( ${_PAR_TARGET} PROPERTIES Fortran_MODULE_DIRECTORY "" ) else() if( NOT _PAR_MODULE_DIRECTORY ) ecbuild_critical( "Missing argument MODULE_DIRECTORY" ) endif() set_target_properties( ${_PAR_TARGET} PROPERTIES Fortran_MODULE_DIRECTORY ${_PAR_MODULE_DIRECTORY} ) target_include_directories( ${_PAR_TARGET} PUBLIC $ ) endif() if( ECBUILD_INSTALL_FORTRAN_MODULES ) if( _PAR_INSTALL_DIRECTORY ) target_include_directories( ${_PAR_TARGET} PUBLIC $ ) install( DIRECTORY ${_PAR_MODULE_DIRECTORY}/ DESTINATION ${_PAR_INSTALL_DIRECTORY} COMPONENT modules ) endif() endif() endmacro() fiat-ecmwf-2.0.0/AUTHORS0000664000175000017500000000107215157200431014765 0ustar alastairalastairAuthors and Contributors ======================== - A. Beggs (ECMWF) - W. Deconinck (ECMWF) - D. Dent (ECMWF) - R. El Khatib (Meteo France) - P. Gillies (ECMWF) - I. Hadade (ECMWF) - J. Hague (ECMWF) - M. Hamrud (ECMWF) - P. Marguinaud (Meteo France) - O. Marsden (ECMWF) - U. Modigliani (ECMWF) - G. Mozdzynski (ECMWF) - D. Salmond (ECMWF) - S. Saarinen (ECMWF) - P. Towers (ECMWF) - Y. Tremolet (ECMWF) - F. Vana (ECMWF) - F. Suzat (Meteo France) - T. Wilhelmsson (ECMWF) If you have contributed to this project, please add your name in the above alphabetical list. fiat-ecmwf-2.0.0/CMakeLists.txt0000664000175000017500000001305715157200431016463 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # (C) Copyright 2024- Meteo-France. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation # nor does it submit to any jurisdiction. cmake_minimum_required( VERSION 3.12 FATAL_ERROR ) find_package( ecbuild 3.4 REQUIRED HINTS ${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/../ecbuild ) project( fiat LANGUAGES Fortran C CXX ) include( fiat_macros ) ecbuild_enable_fortran( REQUIRED NO_MODULE_DIRECTORY ) set(CMAKE_C_STANDARD 99) set(CMAKE_C_STANDARD_REQUIRED TRUE) set(CMAKE_CXX_STANDARD 11) set(CMAKE_CXX_STANDARD_REQUIRED TRUE) ### Options ecbuild_add_option( FEATURE OMP DESCRIPTION "Support for OpenMP shared memory parallelism" REQUIRED_PACKAGES "OpenMP COMPONENTS Fortran" ) ecbuild_add_option( FEATURE MPI DESCRIPTION "Support for MPI distributed parallelism" REQUIRED_PACKAGES "MPI COMPONENTS Fortran" ) ecbuild_add_option( FEATURE DR_HOOK_PAPI DEFAULT OFF DESCRIPTION "Support for HW counters in DR_HOOK via PAPI" REQUIRED_PACKAGES "PAPI") ecbuild_find_package( fckit QUIET ) ecbuild_add_option( FEATURE FCKIT DESCRIPTION "Support for fckit" CONDITION fckit_FOUND AND fckit_HAVE_ECKIT ) ecbuild_add_option( FEATURE DR_HOOK_MULTI_PRECISION_HANDLES DESCRIPTION "[DEPRECATED] Support single precision handles for DR_HOOK" DEFAULT OFF ) ecbuild_add_option( FEATURE DOUBLE_PRECISION DEFAULT ON DESCRIPTION "Support for Double Precision" ) ecbuild_add_option( FEATURE SINGLE_PRECISION DEFAULT ON DESCRIPTION "Support for Single Precision" ) ecbuild_add_option( FEATURE DUMMY_MPI_HEADER DEFAULT ON DESCRIPTION "[DANGEROUS] Install a dummy MPI header" ) # Two MPL interface styles # - DEPRECATED F77 based interface, relies on mpif.h, can't take non-contiguous arrays # - MPI_F08 based interface, relies on mpi_f08 module # NB : both interfaces can be compiled without MPI, and then link to mpi_serial library set( MPL_F77_DEPRECATED_DEFAULT OFF ) if( HAVE_MPI AND NOT MPI_Fortran_HAVE_F08_MODULE ) ecbuild_warn( "MPI Fortran present, but no MPI-F08 support found, so building with FEATURE MPL_F77_DEPRECATED DEFAULT ON. " "Please check your MPI installation for MPI-F08 support." ) set( MPL_F77_DEPRECATED_DEFAULT ON ) endif() ecbuild_add_option( FEATURE MPL_F77_DEPRECATED DESCRIPTION "[DEPRECATED] Compile deprecated 'mpif.h'-based MPL instead of MPI_F08 version" REQUIRED_PACKAGES "MPI COMPONENTS Fortran" DEFAULT ${MPL_F77_DEPRECATED_DEFAULT} ) ecbuild_add_option( FEATURE MPL_CHECK_CONTIG DESCRIPTION "Enable runtime check of contiguity of array arguments passed to MPL routines" DEFAULT OFF ) ecbuild_add_option( FEATURE WARNINGS DEFAULT ON DESCRIPTION "Add warnings to compiler" ) if(CMAKE_C_COMPILER_ID STREQUAL "PGI" OR CMAKE_C_COMPILER_ID STREQUAL "NVHPC" ) set (DEFAULT_DR_HOOK_NVTX ON) else() set (DEFAULT_DR_HOOK_NVTX OFF) endif() ecbuild_add_option( FEATURE DR_HOOK_NVTX DEFAULT ${DEFAULT_DR_HOOK_NVTX} DESCRIPTION "Support for NVTX in DR_HOOK" REQUIRED_PACKAGES NVTX ) set (DEFAULT_DR_HOOK_ROCTX OFF) ecbuild_add_option( FEATURE DR_HOOK_ROCTX DEFAULT ${DEFAULT_DR_HOOK_ROCTX} DESCRIPTION "Support for ROCTX in DR_HOOK" REQUIRED_PACKAGES ROCTX ) ecbuild_find_package( NAME Realtime QUIET ) if( ${CMAKE_SYSTEM_NAME} MATCHES "Darwin") set(_whole_archive "-Wl,-force_load") set(_no_whole_archive "") else() if("${CMAKE_Fortran_COMPILER_ID}" MATCHES "NAG") set(_whole_archive "-Wl,-Wl,,--whole-archive") set(_no_whole_archive "-Wl,-Wl,,--no-whole-archive") else() set(_whole_archive "-Wl,--whole-archive") set(_no_whole_archive "-Wl,--no-whole-archive") endif() endif() ### Sources # define MPI_SERIAL_LIBRARIES before including src folder, for use in fiat library declaration set(MPI_SERIAL_LIBRARIES ${_whole_archive} mpi_serial ${_no_whole_archive}) include( fiat_compiler_warnings ) add_subdirectory(src) add_subdirectory(share) ### Tests add_subdirectory(tests) ### Export if (fiat_HAVE_MPL_F77_DEPRECATED) set (fiat_HAVE_MPL_F08 0) else() set (fiat_HAVE_MPL_F08 1) endif() set( fiat_REQUIRES_PRIVATE_DEPENDENCIES FALSE ) get_target_property( target_build_type fiat TYPE ) if( target_build_type STREQUAL STATIC_LIBRARY OR TARGET fiat-static ) set( fiat_REQUIRES_PRIVATE_DEPENDENCIES TRUE ) # Make find_package modules available to downstream packages foreach( find_module FindNVTX.cmake FindROCTX.cmake FindPAPI.cmake ) if(NOT EXISTS "${CMAKE_CURRENT_BINARY_DIR}/${find_module}") execute_process( COMMAND ${CMAKE_COMMAND} -E create_symlink "${CMAKE_CURRENT_SOURCE_DIR}/cmake/${find_module}" "${CMAKE_CURRENT_BINARY_DIR}/${find_module}" ) endif() install( FILES "${CMAKE_CURRENT_SOURCE_DIR}/cmake/${find_module}" DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/fiat" ) endforeach() endif() ecbuild_install_project( NAME fiat ) ecbuild_print_summary() fiat-ecmwf-2.0.0/.github/0000775000175000017500000000000015157200431015255 5ustar alastairalastairfiat-ecmwf-2.0.0/.github/workflows/0000775000175000017500000000000015157200431017312 5ustar alastairalastairfiat-ecmwf-2.0.0/.github/workflows/build.yml0000664000175000017500000001706515157200431021145 0ustar alastairalastairname: build # Controls when the action will run on: # Trigger the workflow on all pushes, except on tag creation push: branches: - '**' tags-ignore: - '**' # Trigger the workflow on all pull requests pull_request: ~ # Allow workflow to be dispatched on demand workflow_dispatch: ~ env: FIAT_TOOLS: ${{ github.workspace }}/.github/tools CTEST_PARALLEL_LEVEL: 1 CACHE_SUFFIX: v2 # Increase to force new cache to be created jobs: ci: name: ci strategy: fail-fast: false # false: try to complete all jobs matrix: build_type: [Release,Debug] name: - linux gnu-10 - linux gnu-12 - linux gnu-14 - linux clang-18 - linux intel - linux intel-classic - linux nvhpc-25.1 - macos include: - name: linux gnu-10 os: ubuntu-22.04 compiler: gnu-10 compiler_cc: gcc-10 compiler_cxx: g++-10 compiler_fc: gfortran-10 caching: true coverage: false - name: linux gnu-12 os: ubuntu-22.04 compiler: gnu-10 compiler_cc: gcc-10 compiler_cxx: g++-10 compiler_fc: gfortran-10 caching: true coverage: true - name: linux gnu-14 os: ubuntu-24.04 compiler: gnu-14 compiler_cc: gcc-14 compiler_cxx: g++-14 compiler_fc: gfortran-14 caching: true coverage: false - name: linux clang-18 os: ubuntu-24.04 compiler: clang-18 compiler_cc: clang-18 compiler_cxx: clang++-18 compiler_fc: gfortran-14 caching: true coverage: false - name : linux intel os: ubuntu-24.04 compiler: intel compiler_cc: icx compiler_cxx: icpx compiler_fc: ifx caching: true coverage: false - name : linux intel-classic os: ubuntu-22.04 compiler: intel-classic compiler_cc: icc compiler_cxx: icpc compiler_fc: ifort caching: true coverage: false - name: linux nvhpc-25.1 os: ubuntu-24.04 compiler: nvhpc-25.1 compiler_cc: nvc compiler_cxx: nvc++ compiler_fc: nvfortran cmake_options: -DCMAKE_CXX_FLAGS=--diag_suppress177 -DMPI_ARGS=--oversubscribe caching: true coverage: false - name: macos # Xcode compiler requires empty environment variables, so we pass null (~) here os: macos-14 compiler: clang-15 compiler_cc: ~ compiler_cxx: ~ compiler_fc: gfortran-13 caching: true coverage: false cmake_options: -DMPI_SLOTS=4 -DMPI_ARGS=--oversubscribe runs-on: ${{ matrix.os }} steps: - name: Checkout Repository uses: actions/checkout@v2 - name: Environment run: | echo "DEPS_DIR=${{ runner.temp }}/deps" >> $GITHUB_ENV echo "CC=${{ matrix.compiler_cc }}" >> $GITHUB_ENV echo "CXX=${{ matrix.compiler_cxx }}" >> $GITHUB_ENV echo "FC=${{ matrix.compiler_fc }}" >> $GITHUB_ENV if [[ "${{ matrix.os }}" =~ macos ]]; then brew install ninja else sudo apt-get update sudo apt-get install ninja-build fi printenv - name: Free Disk Space (Ubuntu) # Free up disk space for nvhpc uses: jlumbroso/free-disk-space@main if: contains( matrix.compiler, 'nvhpc' ) continue-on-error: true with: # this might remove tools that are actually needed, # if set to "true" but frees about 6 GB tool-cache: false # all of these default to true, but feel free to set to # "false" if necessary for your workflow android: true dotnet: true haskell: true large-packages: false # takes too long docker-images: false # takes too long swap-storage: true - name: Retrieve cached dependencies if: matrix.caching id: deps-restore-cache uses: actions/cache/restore@v4 with: path: ${{ env.DEPS_DIR }} key: deps-${{ matrix.os }}-${{ matrix.compiler }}-${{ env.CACHE_SUFFIX }} - name: Install NVHPC compiler if: contains( matrix.compiler, 'nvhpc' ) shell: bash -eux {0} run: | ${FIAT_TOOLS}/install-nvhpc.sh --prefix /opt/nvhpc --version 25.1 source /opt/nvhpc/env.sh echo "${NVHPC_DIR}/compilers/bin" >> $GITHUB_PATH echo "NVHPC_ROOT=${NVHPC_DIR}" >> $GITHUB_ENV [ -z ${MPI_HOME+x} ] || echo "MPI_HOME=${MPI_HOME}" >> $GITHUB_ENV echo "FIAT_TEST_IGNORE_MPI_OUTPUT=1" >> $GITHUB_ENV - name: Install Intel oneAPI compiler if: contains( matrix.compiler, 'intel' ) run: | ${FIAT_TOOLS}/install-intel-oneapi.sh source /opt/intel/oneapi/setvars.sh printenv >> $GITHUB_ENV echo "CACHE_SUFFIX=$CC-$($CC -dumpversion)" >> $GITHUB_ENV - name: Install MPI shell: bash -eux {0} run: | FCFLAGS=-fPIC CFLAGS=-fPIC FFLAGS=-fPIC ${FIAT_TOOLS}/install-mpi.sh --mpi openmpi --prefix ${DEPS_DIR}/openmpi if [[ "${{ matrix.os }}" =~ macos ]]; then echo "CACHE_SUFFIX=${CACHE_SUFFIX}-mpi_$(mpirun --version | head -1 | awk '{print $4}')" >> $GITHUB_ENV fi [ -f ${DEPS_DIR}/openmpi/env.sh ] && source ${DEPS_DIR}/openmpi/env.sh [ -z ${MPI_HOME+x} ] || echo "MPI_HOME=${MPI_HOME}" >> $GITHUB_ENV - name: Save cached dependencies # There seems to be a problem with cached NVHPC dependencies, leading to SIGILL perhaps due to slightly different architectures if: matrix.caching && matrix.build_type == 'Debug' id: deps-save-cache uses: actions/cache/save@v4 with: path: ${{ env.DEPS_DIR }} key: ${{ steps.deps-restore-cache.outputs.cache-primary-key }} - name: Set Build & Test Environment run: | # Add mpirun to path for testing [ -z ${MPI_HOME+x} ] || echo "${MPI_HOME}/bin" >> $GITHUB_PATH - name: Build & Test id: build-test uses: ecmwf-actions/build-package@v2 with: self_coverage: ${{ matrix.coverage }} force_build: true cache_suffix: "${{ matrix.build_type }}-${{ env.CACHE_SUFFIX }}" recreate_cache: ${{ matrix.caching == false }} dependencies: | ecmwf/ecbuild ecmwf/eckit ecmwf/fckit dependency_branch: develop dependency_cmake_options: | ecmwf/eckit: "-G Ninja -DCMAKE_BUILD_TYPE=${{ matrix.build_type }} -DENABLE_TESTS=OFF -DENABLE_ECKIT_CMD=OFF -DENABLE_ECKIT_SQL=OFF -DENABLE_MPI=ON -DENABLE_OMP=OFF" ecmwf/fckit: "-G Ninja -DCMAKE_BUILD_TYPE=${{ matrix.build_type }} -DENABLE_TESTS=OFF" cmake_options: "-G Ninja -DCMAKE_BUILD_TYPE=${{ matrix.build_type }} ${{ matrix.cmake_options }} -DENABLE_MPI=ON" ctest_options: "${{ matrix.ctest_options }}" # - name: Verify tools # run: | # export PATH=${{ steps.build-test.outputs.bin_path }}:$PATH # # echo "+ fiat --info" # fiat --info # - name: Codecov Upload # if: steps.build-test.outputs.coverage_file # uses: codecov/codecov-action@v2 # with: # files: ${{ steps.build-test.outputs.coverage_file }} fiat-ecmwf-2.0.0/.github/tools/0000775000175000017500000000000015157200431016415 5ustar alastairalastairfiat-ecmwf-2.0.0/.github/tools/reduce-output.sh0000775000175000017500000000231515157200431021562 0ustar alastairalastair#!/bin/bash # (C) Copyright 2013 ECMWF. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # In applying this licence, ECMWF does not waive the privileges and immunities # granted to it by virtue of its status as an intergovernmental organisation nor # does it submit to any jurisdiction. # Abort on Error set -e PING_SLEEP=30s dump_output() { echo " ++ Tailing the last 100 lines of output from $BUILD_OUTPUT" tail -100 $BUILD_OUTPUT } error_handler() { echo ERROR: An error was encountered with the build. kill $PING_LOOP_PID dump_output exit 1 } # If an error occurs, run our error handler to output a tail of the build trap 'error_handler' ERR # Set up a repeating loop to display some output regularly. bash -c "while true; do sleep $PING_SLEEP; echo \" ++ \$(date) - running ... \"; done" & PING_LOOP_PID=$! BUILD_OUTPUT=build-$PING_LOOP_PID.out touch $BUILD_OUTPUT echo " + $@" echo " ++ Output redirected to $BUILD_OUTPUT" $@ >> $BUILD_OUTPUT 2>&1 # The build finished without returning an error so dump a tail of the output dump_output # nicely terminate the ping output loop kill $PING_LOOP_PID fiat-ecmwf-2.0.0/.github/tools/install-mpi.sh0000775000175000017500000001170715157200431021213 0ustar alastairalastair#!/bin/bash set +x set -e -o pipefail SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" export PATH=$SCRIPTDIR:$PATH # Some defaults for the arguments PREFIX=$(pwd)/${MPI} mpi_override=false MPI=openmpi while [ $# != 0 ]; do case "$1" in "--prefix") PREFIX="$2"; shift ;; "--override") mpi_override=true; ;; "--version") mpi_version="$2"; shift ;; "--mpi") MPI="$2"; shift ;; *) echo "Unrecognized argument '$1'" exit 1 ;; esac shift done os=$(uname) OMPIVER=4.1.1 MPICHVER=3.4.2 if [ ! -z ${mpi_version+x} ]; then if [[ "${MPI}" =~ [Oo][Pp][Ee][Nn]\-?[Mm][Pp][Ii] ]]; then OMPIVER=${mpi_version} fi if [[ "${MPI}" =~ [Mm][Pp][Ii][Cc][Hh] ]]; then MPICHVER=${mpi_version} fi fi mkdir -p ${PREFIX} touch ${PREFIX}/env.sh MPI_INSTALLED=false case "$os" in Darwin) case "$MPI" in mpich) brew ls --versions mpich || brew install mpich ;; openmpi) brew ls --versions openmpi || brew install openmpi echo "localhost slots=72" >> $(brew --prefix)/etc/openmpi-default-hostfile echo "localhost slots=72" >> $(brew --prefix)/etc/prte-default-hostfile # workaround for open-mpi/omp#7516 echo "setting the mca gds to hash..." echo "gds = hash" >> $(brew --prefix)/etc/pmix-mca-params.conf # workaround for open-mpi/ompi#5798 echo "setting the mca btl_vader_backing_directory to /tmp..." echo "btl_vader_backing_directory = /tmp" >> $(brew --prefix)/etc/openmpi-mca-params.conf ;; *) echo "Unknown MPI implementation: $MPI" exit 1 ;; esac ;; Linux) if [ -n "${MPI_HOME}" ]; then echo "MPI is already installed at MPI_HOME=${MPI_HOME}." echo "Not taking any action." exit 0 fi case "$MPI" in mpich) if [ -f ${PREFIX}/include/mpi.h ]; then echo "${PREFIX}/include/mpi.h found" fi if [ -f ${PREFIX}/lib/libmpich.so ]; then echo "${PREFIX}/lib/libmpich.so found -- nothing to build." else echo "Downloading mpich source..." wget http://www.mpich.org/static/downloads/${MPICHVER}/mpich-${MPICHVER}.tar.gz tar xfz mpich-${MPICHVER}.tar.gz rm mpich-${MPICHVER}.tar.gz echo "Configuring and building mpich..." cd mpich-${MPICHVER} unset F90 unset F90FLAGS ${SCRIPTDIR}/reduce-output.sh ./configure \ --prefix=${PREFIX} \ --enable-static=false \ --enable-alloca=true \ --enable-threads=single \ --enable-fortran=yes \ --enable-fast=all \ --enable-g=none \ --enable-timing=none ${SCRIPTDIR}/reduce-output.sh make -j48 ${SCRIPTDIR}/reduce-output.sh make install MPI_INSTALLED=true cd - rm -rf mpich-${MPICHVER} fi ;; openmpi) if [ -f ${PREFIX}/include/mpi.h ]; then echo "openmpi/include/mpi.h found." fi if [ -f ${PREFIX}/lib/libmpi.so ] || [ -f ${PREFIX}/lib64/libmpi.so ]; then echo "libmpi.so found -- nothing to build." else echo "Downloading openmpi source..." wget --no-check-certificate https://www.open-mpi.org/software/ompi/v4.1/downloads/openmpi-$OMPIVER.tar.gz tar -zxf openmpi-$OMPIVER.tar.gz rm openmpi-$OMPIVER.tar.gz echo "Configuring and building openmpi..." cd openmpi-$OMPIVER ${SCRIPTDIR}/reduce-output.sh ./configure --prefix=${PREFIX} ${SCRIPTDIR}/reduce-output.sh make -j4 ${SCRIPTDIR}/reduce-output.sh make install MPI_INSTALLED=true echo "localhost slots=72" >> ${PREFIX}/etc/openmpi-default-hostfile cd - rm -rf openmpi-$OMPIVER fi ;; *) echo "Unknown MPI implementation: $MPI" exit 1 ;; esac ;; *) echo "Unknown operating system: $os" exit 1 ;; esac if ${MPI_INSTALLED} ; then cat > ${PREFIX}/env.sh << EOF export MPI_HOME=${PREFIX} export PATH=\${MPI_HOME}/bin:\${PATH} EOF echo "Please source ${PREFIX}/env.sh, containing:" cat ${PREFIX}/env.sh fi fiat-ecmwf-2.0.0/.github/tools/install-intel-oneapi.sh0000775000175000017500000000074115157200431023006 0ustar alastairalastair#!/usr/bin/env bash version=2023.2.0 KEY=GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB wget https://apt.repos.intel.com/intel-gpg-keys/$KEY sudo apt-key add $KEY rm $KEY echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list sudo apt-get update sudo apt-get install \ intel-oneapi-compiler-fortran-$version \ intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-$version \ intel-oneapi-mpi-devel-2021.10.0 \ intel-oneapi-mkl-$version fiat-ecmwf-2.0.0/.github/tools/install-nvhpc.sh0000775000175000017500000000613515157200431021543 0ustar alastairalastair#!/bin/sh # Install NVHPC # https://github.com/nemequ/pgi-travis # # Originally written for Squash by # Evan Nemerson. For documentation, bug reports, support requests, # etc. please use . # # To the extent possible under law, the author(s) of this script have # waived all copyright and related or neighboring rights to this work. # See for # details. version=24.3 TEMPORARY_FILES="${TMPDIR:-/tmp}" export NVHPC_INSTALL_DIR=$(pwd)/nvhpc-install export NVHPC_SILENT=true while [ $# != 0 ]; do case "$1" in "--prefix") export NVHPC_INSTALL_DIR="$2"; shift ;; "--tmpdir") TEMPORARY_FILES="$2"; shift ;; "--verbose") export NVHPC_SILENT=false; ;; "--version") version="$2"; shift ;; *) echo "Unrecognized argument '$1'" exit 1 ;; esac shift done case "$(uname -m)" in x86_64|ppc64le|aarch64) ;; *) echo "Unknown architecture: $(uname -m)" >&2 exit 1 ;; esac if [ -d "${NVHPC_INSTALL_DIR}" ]; then if [[ $(find "${NVHPC_INSTALL_DIR}" -name "nvc" | wc -l) == 1 ]]; then echo "NVHPC already installed at ${NVHPC_INSTALL_DIR}" exit fi fi # Example download URL for version 24.3 # https://developer.download.nvidia.com/hpc-sdk/24.3/nvhpc_2024_243_Linux_x86_64_cuda_12.3.tar.gz ver="$(echo $version | tr -d . )" URL=$(curl -s "https://developer.nvidia.com/nvidia-hpc-sdk-$ver-downloads" | grep -oP "https://developer.download.nvidia.com/hpc-sdk/([0-9]{2}\.[0-9]+)/nvhpc_([0-9]{4})_([0-9]+)_Linux_$(uname -m)_cuda_([0-9\.]+).tar.gz" | sort | tail -1) FOLDER="$(basename "$(echo "${URL}" | grep -oP '[^/]+$')" .tar.gz)" if [ ! -d "${TEMPORARY_FILES}/${FOLDER}" ]; then echo "Downloading ${TEMPORARY_FILES}/${FOLDER} from URL [${URL}]" mkdir -p ${TEMPORARY_FILES} curl --location \ --user-agent "pgi-travis (https://github.com/nemequ/pgi-travis)" \ "${URL}" | tar zx -C "${TEMPORARY_FILES}" else echo "Download already present in ${TEMPORARY_FILES}/${FOLDER}" fi echo "+ ${TEMPORARY_FILES}/${FOLDER}/install" "${TEMPORARY_FILES}/${FOLDER}/install" #comment out to cleanup #rm -rf "${TEMPORARY_FILES}/${FOLDER}" NVHPC_VERSION=$(basename "${NVHPC_INSTALL_DIR}"/Linux_$(uname -m)/*.*/) # Use gcc which is available in PATH ${NVHPC_INSTALL_DIR}/Linux_$(uname -m)/${NVHPC_VERSION}/compilers/bin/makelocalrc \ -x ${NVHPC_INSTALL_DIR}/Linux_$(uname -m)/${NVHPC_VERSION}/compilers/bin \ -gcc $(which gcc) \ -gpp $(which g++) \ -g77 $(which gfortran) cat > ${NVHPC_INSTALL_DIR}/env.sh << EOF ### Variables export NVHPC_INSTALL_DIR=${NVHPC_INSTALL_DIR} export NVHPC_VERSION=${NVHPC_VERSION} export NVHPC_DIR=\${NVHPC_INSTALL_DIR}/Linux_$(uname -m)/\${NVHPC_VERSION} ### Compilers export PATH=\${NVHPC_DIR}/compilers/bin:\${PATH} export NVHPC_LIBRARY_PATH=\${NVHPC_DIR}/compilers/lib export LD_LIBRARY_PATH=\${NVHPC_LIBRARY_PATH} ### MPI export MPI_HOME=\${NVHPC_DIR}/comm_libs/mpi export PATH=\${MPI_HOME}/bin:\${PATH} EOF cat ${NVHPC_INSTALL_DIR}/env.sh