diff --git a/AUTHORS b/AUTHORS index c8f0a1ccc..43724eccd 100644 --- a/AUTHORS +++ b/AUTHORS @@ -1,20 +1,21 @@ Authors and Contributors ======================== +- P. Courtier (ECMWF) - W. Deconinck (ECMWF) +- D. Degrauwe (RMI) - D. Dent (ECMWF) - P. Dueben (ECMWF) - R. El Khatib (Meteo France) +- D. Giard (Meteo France) - J. Hague (ECMWF) - M. Hamrud (ECMWF) +- M. Hortal (ECMWF) - L. Isaksen (ECMWF) -- G. Mozdzynski (ECMWF) - P. Marguinaud (Meteo France) +- L. Mosimann (NVIDIA) +- G. Mozdzynski (ECMWF) - A. Mueller (ECMWF) -- M. Hortal (ECMWF) -- P. Courtier (ECMWF) -- D. Degrauwe (RMI) -- D. Giard (Meteo France) - G. Radnoti (ECMWF) - D. Salmond (ECMWF) - Y. Seity (Meteo France) diff --git a/CMakeLists.txt b/CMakeLists.txt index f5c833fb2..85f0bf425 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -9,7 +9,7 @@ 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( ectrans LANGUAGES C Fortran ) +project( ectrans LANGUAGES C CXX Fortran ) include( ectrans_macros ) ecbuild_enable_fortran( REQUIRED NO_MODULE_DIRECTORY ) diff --git a/src/programs/CMakeLists.txt b/src/programs/CMakeLists.txt index 731a492ae..8fc85159e 100644 --- a/src/programs/CMakeLists.txt +++ b/src/programs/CMakeLists.txt @@ -1,4 +1,5 @@ # (C) Copyright 2020- ECMWF. +# (C) Copyright 2022- NVIDIA. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -25,20 +26,16 @@ if( HAVE_TOOLS AND TARGET eccodes_f90 ) LIBS ${trans} eccodes_f90 LINKER_LANGUAGE Fortran DEFINITIONS ECTRANS_TOOLS_RTABLE_PATH="${ECTRANS_TOOLS_RTABLE_PATH}" ) - endforeach() - - endif() - set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) if( HAVE_GPU ) foreach( prec sp dp ) if( HAVE_${prec} ) - ecbuild_add_executable(TARGET driver-spectrans-${prec} + ecbuild_add_executable(TARGET driver-spectrans-CA-${prec} SOURCES driver-spectraltransform.F90 INCLUDES ${MPI_Fortran_INCLUDE_PATH} @@ -47,14 +44,18 @@ if( HAVE_GPU ) fiat parkind_${prec} eccodes_f90 eccodes_memfs ${MPI_Fortran_LIBRARIES} - trans_gpu_static_${prec} + trans_gpu_static_CA_${prec} gpu OpenACC::OpenACC_Fortran ${LAPACK_LIBRARIES} nvhpcwrapnvtx ) - ecbuild_add_executable(TARGET driver-spectrans-CA-${prec} - SOURCES driver-spectraltransform.F90 + set_property( TARGET driver-spectrans-CA-${prec} PROPERTY CUDA_ARCHITECTURES 70 ) + target_compile_options( driver-spectrans-CA-${prec} PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc,pinned -cudalib=cufft,cublas -fpic> ) + set_target_properties(driver-spectrans-CA-${prec} PROPERTIES LINK_FLAGS "-acc -cudalib=cufft,cublas -fpic -gpu=cc70,pinned") + + ecbuild_add_executable(TARGET driver-spectrans-CA-${prec}-indiv + SOURCES driver-spectraltransform_indiv.F90 INCLUDES ${MPI_Fortran_INCLUDE_PATH} $ @@ -68,17 +69,9 @@ if( HAVE_GPU ) ${LAPACK_LIBRARIES} nvhpcwrapnvtx ) - #trans_gpu_static_${prec} - #gpu - #${CMAKE_BINARY_DIR}/lib/libtrans_gpu_static_${prec}.a - #${CMAKE_BINARY_DIR}/lib/libgpu.a - #target_link_libraries( driver-spectrans PRIVATE OpenACC::OpenACC_Fortran ) - set_property( TARGET driver-spectrans-${prec} PROPERTY CUDA_ARCHITECTURES 70 ) - set_property( TARGET driver-spectrans-CA-${prec} PROPERTY CUDA_ARCHITECTURES 70 ) - target_compile_options( driver-spectrans-${prec} PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc -cudalib=cufft,cublas -fpic> ) - target_compile_options( driver-spectrans-CA-${prec} PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc -cudalib=cufft,cublas -fpic> ) - set_target_properties(driver-spectrans-${prec} PROPERTIES LINK_FLAGS "-acc -cudalib=cufft,cublas -fpic") - set_target_properties(driver-spectrans-CA-${prec} PROPERTIES LINK_FLAGS "-acc -cudalib=cufft,cublas -fpic") + set_property( TARGET driver-spectrans-CA-${prec}-indiv PROPERTY CUDA_ARCHITECTURES 70 ) + target_compile_options( driver-spectrans-CA-${prec}-indiv PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc,pinned -cudalib=cufft,cublas -fpic> ) + set_target_properties(driver-spectrans-CA-${prec}-indiv PROPERTIES LINK_FLAGS "-acc -cudalib=cufft,cublas -fpic -gpu=cc70,pinned") message("Building ${prec} GPU driver") endif() endforeach() diff --git a/src/programs/driver-spectraltransform.F90 b/src/programs/driver-spectraltransform.F90 index 25064a71d..4b8fb29c3 100644 --- a/src/programs/driver-spectraltransform.F90 +++ b/src/programs/driver-spectraltransform.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2014- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -76,13 +77,17 @@ PROGRAM TRANSFORM_TEST REAL(KIND=JPRB), POINTER :: ZT(:,:,:) => NULL() REAL(KIND=JPRB), ALLOCATABLE :: ZSP(:,:) +REAL(KIND=JPRB),ALLOCATABLE :: PAVE(:) +REAL(KIND=JPRB),ALLOCATABLE :: PMIN(:) +REAL(KIND=JPRB),ALLOCATABLE :: PMAX(:) + LOGICAL :: LSTACK LOGICAL :: LDONE,LSTDEV LOGICAL :: LUSERPNM, LKEEPRPNM, LUSEFLT LOGICAL :: LTRACE_STATS,LSTATS_OMP, LSTATS_COMMS, LSTATS_MPL LOGICAL :: LSTATS,LBARRIER_STATS, LBARRIER_STATS2, LDETAILED_STATS LOGICAL :: LSTATS_ALLOC, LSYNCSTATS, LSTATSCPU, LSTATS_MEM -LOGICAL :: LXML_STATS +LOGICAL :: LXML_STATS, LDUMP LOGICAL :: LFFTW INTEGER(KIND=JPIM) :: NSTATS_MEM, NTRACE_STATS, NPRNT_STATS ! 0 - no output, 1 - init and final result, 2 - every timestep @@ -140,7 +145,7 @@ PROGRAM TRANSFORM_TEST & LUSERPNM, LKEEPRPNM, LUSEFLT, NQ, NLIN, IMAX_FLDS_IN, & & NPRINTNORMS, ITERS, ZMAXERR_CHECK, NPROMA, NPROMATR, LEQ_REGIONS, & & NPRINTLEV, NPRTRW, NPRTRV, NSPECRESMIN, NFLEVG, MBX_SIZE, LSTACK, & - & LFFTW + & LFFTW, LDUMP ! ------------------------------------------------------------------ @@ -148,6 +153,7 @@ PROGRAM TRANSFORM_TEST #include "setup_trans.h" #include "inv_trans.h" #include "dir_trans.h" +#include "gpnorm_trans.h" #include "dist_spec.h" #include "gath_grid.h" #include "trans_inq.h" @@ -200,6 +206,7 @@ PROGRAM TRANSFORM_TEST LBARRIER_STATS2=.FALSE. LSTATSCPU=.FALSE. LSYNCSTATS=.FALSE. +LDUMP=.TRUE. LXML_STATS=.FALSE. LTRACE_STATS=.FALSE. NSTATS_MEM=0 @@ -243,7 +250,7 @@ PROGRAM TRANSFORM_TEST ! Participating processors limited by -P option !-------------------------- -CALL MPL_INIT() +CALL MPL_INIT(LDENV=.false.) !IF( LSTATS ) CALL GSTATS(0,0) ZTINIT=TIMEF() @@ -308,7 +315,11 @@ PROGRAM TRANSFORM_TEST IF( NPRTRV*NPRTRW /= NPROC ) CYCLE IF( NPRTRV > NPRTRW ) EXIT IF( NPRTRW > NSPECRESMIN ) CYCLE +! With CUDA AWARE MPI we don't need any OpenMP so there is no need for this! Effectively this is even +! undesireable because it may trigger different domain decompositions for no reasons on different machines +#ifndef USE_CUDA_AWARE_MPI_FT IF( NPRTRW <= NSPECRESMIN/(2*OML_MAX_THREADS()) ) EXIT +#endif ENDDO ! GO FOR APPROX SQUARE PARTITION FOR BACKUP IF( NPRTRV*NPRTRW /= NPROC .OR. NPRTRW > NSPECRESMIN .OR. NPRTRV > NPRTRW ) THEN @@ -771,6 +782,10 @@ PROGRAM TRANSFORM_TEST ALLOCATE(ZGMV(NPROMA,NFLEVG,NDIMGMV,NGPBLKS)) ALLOCATE(ZGMVS(NPROMA,NDIMGMVS,NGPBLKS)) +ALLOCATE(PMIN(NFLEVG)) +ALLOCATE(PMAX(NFLEVG)) +ALLOCATE(PAVE(NFLEVG)) + ALLOCATE(ZNORMSP(1)) ALLOCATE(ZNORMSP1(1)) ALLOCATE(ZNORMVOR(NFLEVG)) @@ -857,10 +872,9 @@ PROGRAM TRANSFORM_TEST ZTSTEP1(JSTEP)=(TIMEF()-ZTSTEP1(JSTEP))/1000.0_JPRD ! Dump a field to a binary file - CALL DUMP_GRIDPOINT_FIELD(JSTEP, MYPROC, NPROMA, NGPBLKS, ZGMVS(:,1,:), 'S', NOUTDUMP) - CALL DUMP_GRIDPOINT_FIELD(JSTEP, MYPROC, NPROMA, NGPBLKS, ZWINDS(:,NFLEVG,3,:), 'U', NOUTDUMP) - CALL DUMP_GRIDPOINT_FIELD(JSTEP, MYPROC, NPROMA, NGPBLKS, ZWINDS(:,NFLEVG,4,:), 'V', NOUTDUMP) - CALL DUMP_GRIDPOINT_FIELD(JSTEP, MYPROC, NPROMA, NGPBLKS, ZGMV(:,NFLEVG,5,:), 'T', NOUTDUMP) + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_3D(JSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_4D(JSTEP, MYPROC, ZWINDS(:,:,:,:), 'W', NOUTDUMP) + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_4D(JSTEP, MYPROC, ZGMV(:,:,:,:), 'M', NOUTDUMP) ZTSTEP2(JSTEP)=TIMEF() CALL DIR_TRANS(PSPVOR=ZVOR,PSPDIV=ZDIV,& @@ -871,6 +885,12 @@ PROGRAM TRANSFORM_TEST & PGP3A=ZGMV(:,:,5:5,:)) ZTSTEP2(JSTEP)=(TIMEF()-ZTSTEP2(JSTEP))/1000.0_JPRD + ! Dump a field to a binary file + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_2D(JSTEP, MYPROC, ZVOR(:,:), 'V', NOUTDUMP) + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_2D(JSTEP, MYPROC, ZDIV(:,:), 'D', NOUTDUMP) + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_2D(JSTEP, MYPROC, ZSP(:,:), 'P', NOUTDUMP) + IF (LDUMP) CALL DUMP_GRIDPOINT_FIELD_3D(JSTEP, MYPROC, ZT(:,:,:), 'T', NOUTDUMP) + ZTSTEP(JSTEP)=(TIMEF()-ZTSTEP(JSTEP))/1000.0_JPRD ZTSTEPAVG=ZTSTEPAVG+ZTSTEP(JSTEP) @@ -921,8 +941,32 @@ PROGRAM TRANSFORM_TEST ELSE WRITE(NOUT,'("time step ",I6," took", F8.4)') JSTEP,ZTSTEP(JSTEP) ENDIF + flush(nout) + ! call acc_present_dump() + ! print *, "going to free in 3 seconds" + ! call sleep (1) + ! print *, "going to free in 2 seconds" + ! call sleep (1) + ! print *, "going to free in 1 seconds" + ! call sleep (1) + ! !call acc_clear_freelists() + ! call sleep (5) + ! !call acc_present_dump() + ! !call sleep (10000) ENDDO +CALL GPNORM_TRANS(ZWINDS(:,:,2,:),NFLEVG,KPROMA=NPROMA,PAVE=PAVE,PMIN=PMIN,PMAX=PMAX,LDAVE_ONLY=.false.,KRESOL=1) +if (myproc == 1) then + OPEN(800+myproc, FORM="UNFORMATTED") + write(800+myproc) "pave", sum(pave)/size(pave) + write(800+myproc) "pmin", sum(pmin)/size(pmin) + write(800+myproc) "pmax", sum(pmax)/size(pmax) + close(800+myproc) + print *, "pave", sum(pave)/size(pave) + print *, "pmin", sum(pmin)/size(pmin) + print *, "pmax", sum(pmax)/size(pmax) +endif + ZTLOOP=(TIMEF()-ZTLOOP)/1000.0_JPRD WRITE(NOUT,'(" ")') @@ -1266,28 +1310,77 @@ SUBROUTINE SORT(A, N) ! ------------------------------------------------------------------ -SUBROUTINE DUMP_GRIDPOINT_FIELD(JSTEP, MYPROC, NPROMA, NGPBLKS, FLD, FLDCHAR, NOUTDUMP) +SUBROUTINE DUMP_GRIDPOINT_FIELD_2D(JSTEP, MYPROC, FLD, FLDCHAR, NOUTDUMP) ! Dump a 2D field to a binary file. INTEGER(KIND=JPIM), INTENT(IN) :: JSTEP ! Time step, used for naming file INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC ! MPI rank, used for naming file -INTEGER(KIND=JPIM), INTENT(IN) :: NPROMA ! Size of NPROMA -INTEGER(KIND=JPIM), INTENT(IN) :: NGPBLKS ! Number of NPROMA blocks -REAL(KIND=JPRB) , INTENT(IN) :: FLD(NPROMA,NGPBLKS) ! 2D field +REAL(KIND=JPRB) , INTENT(IN) :: FLD(:,:) ! 2D field +CHARACTER , INTENT(IN) :: FLDCHAR ! Single character field identifier +INTEGER(KIND=JPIM), INTENT(IN) :: NOUTDUMP ! Unit number for output file + +CHARACTER(LEN=14) :: FILENAME = "X.XXX.XXXX.dat" +CHARACTER(LEN=60) :: DUMP_DIR + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +CALL GETENV("DUMP_DIR", DUMP_DIR) +IF (TRIM(DUMP_DIR) == "") CALL GETCWD(DUMP_DIR) +OPEN(NOUTDUMP, FILE=TRIM(DUMP_DIR)//'/'//FILENAME, FORM="UNFORMATTED") +WRITE(NOUTDUMP) FLD +CLOSE(NOUTDUMP) + +END SUBROUTINE DUMP_GRIDPOINT_FIELD_2D +SUBROUTINE DUMP_GRIDPOINT_FIELD_3D(JSTEP, MYPROC, FLD, FLDCHAR, NOUTDUMP) + +! Dump a 3D field to a binary file. + +INTEGER(KIND=JPIM), INTENT(IN) :: JSTEP ! Time step, used for naming file +INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC ! MPI rank, used for naming file +REAL(KIND=JPRB) , INTENT(IN) :: FLD(:,:,:) ! 3D field +CHARACTER , INTENT(IN) :: FLDCHAR ! Single character field identifier +INTEGER(KIND=JPIM), INTENT(IN) :: NOUTDUMP ! Unit number for output file + +CHARACTER(LEN=14) :: FILENAME = "X.XXX.XXXX.dat" +CHARACTER(LEN=60) :: DUMP_DIR + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +CALL GETENV("DUMP_DIR", DUMP_DIR) +IF (TRIM(DUMP_DIR) == "") CALL GETCWD(DUMP_DIR) +OPEN(NOUTDUMP, FILE=TRIM(DUMP_DIR)//'/'//FILENAME, FORM="UNFORMATTED") +WRITE(NOUTDUMP) FLD +CLOSE(NOUTDUMP) + +END SUBROUTINE DUMP_GRIDPOINT_FIELD_3D +SUBROUTINE DUMP_GRIDPOINT_FIELD_4D(JSTEP, MYPROC, FLD, FLDCHAR, NOUTDUMP) + +! Dump a 4D field to a binary file. + +INTEGER(KIND=JPIM), INTENT(IN) :: JSTEP ! Time step, used for naming file +INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC ! MPI rank, used for naming file +REAL(KIND=JPRB) , INTENT(IN) :: FLD(:,:,:,:) ! 4D field CHARACTER , INTENT(IN) :: FLDCHAR ! Single character field identifier INTEGER(KIND=JPIM), INTENT(IN) :: NOUTDUMP ! Unit number for output file CHARACTER(LEN=14) :: FILENAME = "X.XXX.XXXX.dat" +CHARACTER(LEN=60) :: DUMP_DIR WRITE(FILENAME(1:1),'(A1)') FLDCHAR WRITE(FILENAME(3:5),'(I3.3)') JSTEP WRITE(FILENAME(7:10),'(I4.4)') MYPROC -OPEN(NOUTDUMP, FILE=FILENAME, FORM="UNFORMATTED") -WRITE(NOUTDUMP) RESHAPE(FLD, (/ NPROMA*NGPBLKS /)) +CALL GETENV("DUMP_DIR", DUMP_DIR) +IF (TRIM(DUMP_DIR) == "") CALL GETCWD(DUMP_DIR) +OPEN(NOUTDUMP, FILE=TRIM(DUMP_DIR)//'/'//FILENAME, FORM="UNFORMATTED") +WRITE(NOUTDUMP) FLD CLOSE(NOUTDUMP) -END SUBROUTINE DUMP_GRIDPOINT_FIELD +END SUBROUTINE DUMP_GRIDPOINT_FIELD_4D END PROGRAM TRANSFORM_TEST diff --git a/src/programs/driver-spectraltransform_indiv.F90 b/src/programs/driver-spectraltransform_indiv.F90 new file mode 100644 index 000000000..55992dbbd --- /dev/null +++ b/src/programs/driver-spectraltransform_indiv.F90 @@ -0,0 +1,1572 @@ +! (C) Copyright 2014- ECMWF. +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 TRANSFORM_TEST + +! +! Spectral transform test +! +! This test performs spectral to real and real to spectral transforms repeated in +! timed loop. +! +! +! Author : George Mozdzynski +! + +USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD +USE OML_MOD ,ONLY : OML_MAX_THREADS +USE MPL_MPIF +USE MPL_MODULE +USE GRIB_API +USE YOMGSTATS, ONLY: JPMAXSTAT, YLSTATS => LSTATS +USE TPM_DISTR, ONLY: D +USE EQ_REGIONS_MOD ,ONLY : MY_REGION_NS, MY_REGION_EW +USE TPM_FIELDS, ONLY: F + +IMPLICIT NONE + +INTEGER(KIND=JPIM) :: RETURN_CODE + +CHARACTER CTYPEG*1 +CHARACTER*127 CINSF, CRTABLE +CHARACTER*127 CGRIDTYPE,CFNAME + +! Maximum latitudes, currently equal to TCO7999 +INTEGER(KIND=JPIM),PARAMETER :: JPMLAT=16000 + +INTEGER(KIND=JPIM) :: ISTACK, GETSTACKUSAGE +REAL(KIND=JPRB), DIMENSION(1) :: ZMAXERR(5), ZERR(5) +REAL(KIND=JPRB) :: ZMAXERRG + +INTEGER(KIND=JPIM) :: NRGRI(JPMLAT) +INTEGER(KIND=JPIM) :: NERR,NULNAM,NLIN,INSF,NSMAX,NDGL,NQ +INTEGER(KIND=JPIM) :: ITABLE,NOUT,NOUTDUMP,NSPEC2,NGPTOT,NGPTOTG,IFLD,IFLDS,ICODE,IOUTSF,JROC,JB +INTEGER(KIND=JPIM) :: IERR,ITAG,NSPEC2G,IRET,NTYPE,I,IGRIBOUT,IMAX_FLDS_IN +INTEGER(KIND=JPIM) :: JF,JA,IB,JPRTRV +INTEGER(KIND=JPIM), DIMENSION(1) :: IPARAM,IGRIB,IEDITION,ICURLEV +INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLOEN(:),ITO(:),NPRCIDS(:) +INTEGER(KIND=JPIM) :: MYPROC,JJ +INTEGER :: JSTEP, JJSTEP +REAL(KIND=JPRD) :: ZTINIT,ZTLOOP,TIMEF, ZTSTEPMAX, ZTSTEPMIN, ZTSTEPAVG, ZTSTEPMED +REAL(KIND=JPRD) :: ZTSTEPMAX1, ZTSTEPMIN1, ZTSTEPAVG1, ZTSTEPMED1 +REAL(KIND=JPRD) :: ZTSTEPMAX2, ZTSTEPMIN2, ZTSTEPAVG2, ZTSTEPMED2 +REAL(KIND=JPRD),ALLOCATABLE :: ZTSTEP(:), ZTSTEP1(:), ZTSTEP2(:) +REAL(KIND=JPRB),ALLOCATABLE :: ZFPDAT(:) +REAL(KIND=JPRB),ALLOCATABLE :: ZNORMSP(:),ZNORMSP1(:),ZNORMDIV(:),ZNORMDIV1(:) +REAL(KIND=JPRB),ALLOCATABLE :: ZNORMVOR(:),ZNORMVOR1(:),ZNORMT(:),ZNORMT1(:) +REAL(KIND=JPRB),ALLOCATABLE :: ZNORM(:),ZNORM1(:) +REAL(KIND=JPRD) :: ZAVEAVE(0:JPMAXSTAT) + +! GRID-POINT SPACE DATA STRUCTURES +REAL(KIND=JPRB), ALLOCATABLE :: ZWINDS (:,:,:,:) ! Multilevel fields at t and t-dt +REAL(KIND=JPRB), ALLOCATABLE, TARGET :: ZGMV (:,:,:,:) ! Multilevel fields at t and t-dt +REAL(KIND=JPRB), ALLOCATABLE, TARGET :: ZGMVS (:,:,:) ! Single level fields at t and t-dt + +! SPECTRAL SPACE DATA STRUCTURES +REAL(KIND=JPRB), ALLOCATABLE :: ZSPVORG(:,:) +REAL(KIND=JPRB), ALLOCATABLE :: ZSPDIVG(:,:) +REAL(KIND=JPRB), ALLOCATABLE :: ZSPSPG(:,:) +REAL(KIND=JPRB), ALLOCATABLE :: ZSPTG(:,:,:) +REAL(KIND=JPRB), ALLOCATABLE, TARGET :: SP3D(:,:,:) +REAL(KIND=JPRB), POINTER :: ZVOR(:,:) => NULL() +REAL(KIND=JPRB), POINTER :: ZDIV(:,:) => NULL() +REAL(KIND=JPRB), POINTER :: ZT(:,:,:) => NULL() +REAL(KIND=JPRB), ALLOCATABLE :: ZSP(:,:) + +LOGICAL :: LSTACK +LOGICAL :: LDONE,LSTDEV +LOGICAL :: LUSERPNM, LKEEPRPNM, LUSEFLT +LOGICAL :: LTRACE_STATS,LSTATS_OMP, LSTATS_COMMS, LSTATS_MPL +LOGICAL :: LSTATS,LBARRIER_STATS, LBARRIER_STATS2, LDETAILED_STATS +LOGICAL :: LSTATS_ALLOC, LSYNCSTATS, LSTATSCPU, LSTATS_MEM +LOGICAL :: LXML_STATS +LOGICAL :: LFFTW +INTEGER(KIND=JPIM) :: NSTATS_MEM, NTRACE_STATS, NPRNT_STATS +! 0 - no output, 1 - init and final result, 2 - every timestep +INTEGER(KIND=JPIM) :: NPRINTNORMS=0 +LOGICAL :: LMPOFF +INTEGER(KIND=JPIM) :: ITERS=100 + +REAL(KIND=JPRB) :: ZMAXERR_CHECK=0.0_JPRB +REAL(KIND=JPRB) :: ZRA=6371229._JPRB + +INTEGER(KIND=JPIM) :: NMAX_RESOL +INTEGER(KIND=JPIM) :: NPRINTLEV +INTEGER(KIND=JPIM) :: NPROMATR +INTEGER(KIND=JPIM) :: NCOMBFLEN + +INTEGER(KIND=JPIM) :: NPROC +INTEGER(KIND=JPIM) :: NTHREAD +INTEGER(KIND=JPIM) :: NPRGPNS +INTEGER(KIND=JPIM) :: NPRGPEW +INTEGER(KIND=JPIM) :: NPRTRV +INTEGER(KIND=JPIM) :: NPRTRW +INTEGER(KIND=JPIM) :: NSPECRESMIN +INTEGER(KIND=JPIM) :: MYSETV +INTEGER(KIND=JPIM) :: MYSETW +INTEGER(KIND=JPIM) :: MYSETA +INTEGER(KIND=JPIM) :: MYSETB +INTEGER(KIND=JPIM) :: MP_TYPE +INTEGER(KIND=JPIM) :: MBX_SIZE + +INTEGER(KIND=JPIM), ALLOCATABLE :: NUMLL(:), IVSET(:), NPSURF(:) +INTEGER(KIND=JPIM) :: IVSETSC(1) +INTEGER(KIND=JPIM) :: NPSP ! Set to 1 if PE has V set with surface variables + +INTEGER(KIND=JPIM) :: NFLEVG, NFLEVL +! SUMPINI +INTEGER(KIND=JPIM) :: ISQR +LOGICAL :: LSYNC_TRANS +LOGICAL :: LEQ_REGIONS + + +INTEGER(KIND=JPIM) :: NPROMA +INTEGER(KIND=JPIM) :: NGPBLKS +! LOCALS +INTEGER(KIND=JPIM) :: IPRTRV +INTEGER(KIND=JPIM) :: IPRTRW +INTEGER(KIND=JPIM) :: IPRUSED, ILEVPP, IREST, ILEV, JLEV, ILASTLEV + +LOGICAL :: LLINFO + +INTEGER(KIND=JPIM) :: NDIMGMV ! Third dim. of GMV "(NPROMA,NFLEVG,NDIMGMV,NGPBLKS)" +INTEGER(KIND=JPIM) :: NDIMGMVS ! Second dim. GMVS "(NPROMA,NDIMGMVS,NGPBLKS)" + +NAMELIST/NAMRGRI/ NRGRI +NAMELIST/NAMTRANS/ LSTATS, LBARRIER_STATS, LBARRIER_STATS2, LDETAILED_STATS, & + & LUSERPNM, LKEEPRPNM, LUSEFLT, NQ, NLIN, IMAX_FLDS_IN, & + & NPRINTNORMS, ITERS, ZMAXERR_CHECK, NPROMA, NPROMATR, LEQ_REGIONS, & + & NPRINTLEV, NPRTRW, NPRTRV, NSPECRESMIN, NFLEVG, MBX_SIZE, LSTACK, & + & LFFTW + +! ------------------------------------------------------------------ + +#include "setup_trans0.h" +#include "setup_trans.h" +#include "inv_trans.h" +#include "dir_trans.h" +#include "dist_spec.h" +#include "gath_grid.h" +#include "trans_inq.h" +#include "specnorm.h" +#include "abor1.intfb.h" +#include "gstats_setup.intfb.h" + +! Default initializations +NERR = 0 +NULNAM = 4 +NOUT = 6 +! Unit number for file to dump 2D fields to +NOUTDUMP = 7 +! Max number of resolutions +NMAX_RESOL=37 +! Print level +NPRINTLEV=0 +! NPROMA for trans lib +NPROMATR=0 +! Size of comm buffer +NCOMBFLEN=1800000 +! EQ REGIONS flag +LEQ_REGIONS=.TRUE. +! Message Passing switch +LMPOFF=.FALSE. +! Activate barrier sync +LSYNC_TRANS=.false. +! Number of procs +NPROC=0 +! Grid-point decomp +NPRGPNS=0 +NPRGPEW=0 +! Spectral decomp +NPRTRW=0 +NPRTRV=0 +! Minimum spectral resolution +! Used for controlling NPRTRW +NSPECRESMIN=0 +! Message passing type +MP_TYPE=2 +! Mailbox size +MBX_SIZE=150000000 +! GSTATS statistics +LSTATS=.FALSE. +LDETAILED_STATS=.FALSE. +LSTATS_OMP=.FALSE. +LSTATS_COMMS=.FALSE. +LSTATS_MPL=.FALSE. +LBARRIER_STATS=.FALSE. +LBARRIER_STATS2=.FALSE. +LSTATSCPU=.FALSE. +LSYNCSTATS=.FALSE. +LXML_STATS=.FALSE. +LTRACE_STATS=.FALSE. +NSTATS_MEM=0 +LSTATS_MEM=.FALSE. +LSTATS_ALLOC=.FALSE. +NTRACE_STATS=0 +NPRNT_STATS=1 +LUSERPNM=.FALSE. +LKEEPRPNM=.FALSE. +! Use fast Legendre transforms +LUSEFLT=.FALSE. +! Output stack info +LSTACK=.FALSE. +! Use FFTW +LFFTW=.TRUE. + +! Default number of vertical levels +NFLEVG=137 +! Number of 3D grid-point fields in GMV +NDIMGMV=9 +! Number of 2D grid-point fields in GMVS +! surface pressure, north south der, east-west der +NDIMGMVS=3 +! Set defaults for options +CINSF = ' ' +CTYPEG = 'r' +LSTDEV = .FALSE. +NLIN = 1 +NDGL = 0 +NQ = 0 +CRTABLE = '.' + +! Locals +ILASTLEV = 0 + +! Read NAMELIST to override defaults +REWIND(NULNAM) +READ(NULNAM,NAMTRANS) + +! Message passing setup +! Participating processors limited by -P option + +!-------------------------- +CALL MPL_INIT() +!IF( LSTATS ) CALL GSTATS(0,0) +ZTINIT=TIMEF() + +NPROC= MPL_NPROC() +MYPROC = MPL_MYRANK() +NTHREAD= OML_MAX_THREADS() + +! ONLY OUTPUT TO STDOUT ON PE 1 +IF( NPROC > 1 ) THEN + IF( MYPROC /= 1 ) THEN + OPEN(UNIT=NOUT, FILE='/dev/null') + ENDIF +ENDIF + +IF(LDETAILED_STATS)THEN + LSTATS_OMP=.TRUE. + LSTATS_COMMS=.TRUE. + LSTATS_MPL=.TRUE. + LSTATSCPU=.TRUE. + NPRNT_STATS=NPROC +! LSTATS_MEM=.TRUE. +! LSTATS_ALLOC=.TRUE. +ENDIF + +!------------------------- + +ALLOCATE(NPRCIDS(NPROC)) +DO JJ=1,NPROC + NPRCIDS(JJ) = JJ +ENDDO + +IF( NPROC <= 1 ) LMPOFF=.TRUE. +! COMPUTE NPRGPNS and NPRGPEW +! THIS VERSION SELECTS MOST SQUARE-LIKE DISTRIBUTION +! THESE WILL CHANGE IF LEQ_REGIONS=.TRUE. +IF( NPROC == 0 ) NPROC = 1 +ISQR=INT(SQRT(REAL(NPROC,JPRB))) +DO JA=ISQR,NPROC + IB=NPROC/JA + IF( JA*IB == NPROC ) THEN + NPRGPNS=MAX(JA,IB) + NPRGPEW=MIN(JA,IB) + EXIT + ENDIF +ENDDO + +! FROM SUMPINI, ALTHOUGH THIS +! SHOULD BE SPECIFIED IN NAMELIST +IF( NSPECRESMIN==0 ) NSPECRESMIN=NPROC + +! COMPUTE NPRTRV AND NPRTRW +! IF NOT PROVIDED IN NAMELIST +IF( NPRTRV > 0 .OR. NPRTRW > 0 ) THEN + IF( NPRTRV == 0 ) NPRTRV=NPROC/NPRTRW + IF( NPRTRW == 0 ) NPRTRW=NPROC/NPRTRV + IF( NPRTRW*NPRTRV /= NPROC ) CALL ABOR1('TRANSFORM_TEST:NPRTRW*NPRTRV /= NPROC') + IF( NPRTRW > NSPECRESMIN ) CALL ABOR1('TRANSFORM_TEST:NPRTRW > NSPECRESMIN') +ELSE + DO JPRTRV=4,NPROC + NPRTRV=JPRTRV + NPRTRW=NPROC/NPRTRV + IF( NPRTRV*NPRTRW /= NPROC ) CYCLE + IF( NPRTRV > NPRTRW ) EXIT + IF( NPRTRW > NSPECRESMIN ) CYCLE + IF( NPRTRW <= NSPECRESMIN/(2*OML_MAX_THREADS()) ) EXIT + ENDDO + ! GO FOR APPROX SQUARE PARTITION FOR BACKUP + IF( NPRTRV*NPRTRW /= NPROC .OR. NPRTRW > NSPECRESMIN .OR. NPRTRV > NPRTRW ) THEN + ISQR=INT(SQRT(REAL(NPROC,JPRB))) + DO JA=ISQR,NPROC + IB=NPROC/JA + IF (JA*IB == NPROC) THEN + NPRTRW=MAX(JA,IB) + NPRTRV=MIN(JA,IB) + IF (NPRTRW > NSPECRESMIN ) CALL ABOR1('TRANSFORM_TEST:NPRTRW & + & (approx square value) > NSPECRESMIN') + EXIT + ENDIF + ENDDO + ENDIF +ENDIF + +! Create communicators for MPI groups +IF (.NOT.LMPOFF) THEN + CALL MPL_GROUPS_CREATE(NPRTRW,NPRTRV) +ENDIF + +IF (LMPOFF) THEN + MYSETW=(MYPROC-1)/NPRTRV+1 + MYSETV=MOD(MYPROC-1,NPRTRV)+1 +ELSE + CALL MPL_CART_COORDS(MYPROC,MYSETW,MYSETV) + ! Just checking for now... + IPRTRV=MOD(MYPROC-1,NPRTRV)+1 + IPRTRW=(MYPROC-1)/NPRTRV+1 + IF (IPRTRV/=MYSETV .OR. IPRTRW/=MYSETW) THEN + CALL ABOR1('TRANSFORM_TEST:Inconsistency when computing MYSETW and MYSETV') + ENDIF +ENDIF + +IF (.NOT.LMPOFF) THEN + LLINFO=.FALSE. + IF (MYPROC == 1) LLINFO=.TRUE. + CALL MPL_BUFFER_METHOD(KMP_TYPE=MP_TYPE,KMBX_SIZE=MBX_SIZE,KPROCIDS=NPRCIDS,LDINFO=LLINFO) +ENDIF + +! Determine number of local levels for Fourier and Legendre calculations +! based on the values of NFLEVG and NPRTRV +ALLOCATE(NUMLL(NPRTRV+1)) + +ALLOCATE(NPSURF(NPRTRV)) + +! Calculate remainder +IPRUSED=MIN(NFLEVG+1,NPRTRV) +ILEVPP=NFLEVG/NPRTRV +IREST=NFLEVG-ILEVPP*NPRTRV +DO JROC=1,NPRTRV + IF(JROC <= IREST) THEN + NUMLL(JROC)=ILEVPP+1 + ELSE + NUMLL(JROC)=ILEVPP + ENDIF +ENDDO +NUMLL(IPRUSED+1:NPRTRV+1)=0 + +NFLEVL=NUMLL(MYSETV) + +DO JROC=1,IPRUSED + NPSURF(JROC)=0 +ENDDO +NPSURF(IPRUSED)=1 +NPSP=NPSURF(MYSETV) +IVSETSC(1)=IPRUSED + +ITAG = 123456 +IFLD=0 +IFLDS=0 + +IF(MYPROC == 1) THEN + IF(CINSF == ' ') THEN + CINSF = 'fort.11' + ENDIF +ENDIF + +IF(CTYPEG == 'r') THEN + NTYPE = 1 +ELSEIF(CTYPEG == 'f') THEN + NTYPE = 0 +ELSE + WRITE(NERR,*) 'WRONG TYPE OF GRID: ',CTYPEG,' It should be',' either f or r' + CALL ABOR1('TRANSFORM_TEST:WRONG TYPE OF GRID') +ENDIF + +ICODE = 0 + +! Find spectral resolution + +IF(MYPROC == 1) THEN + CALL GRIB_OPEN_FILE(INSF,CINSF,'R',IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*) 'ERROR OPENING FILE INPUT SPECTRAL FILE',CINSF,IRET + CALL ABOR1('TRANSFORM_TEST: ERROR OPENING FILE INPUT SPECTRAL FILE') + ENDIF + CALL GRIB_NEW_FROM_FILE(INSF,IGRIB(1),IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'ERROR IN FILE ',CINSF,' : NO INFORMATION' + CALL ABOR1('TRANSFORM_TEST: ERROR GRIB_NEW_FROM_FILE') + ENDIF + CALL GRIB_GET(IGRIB(1),'gridType',CGRIDTYPE,IRET) + IF(CGRIDTYPE /= 'sh') THEN + WRITE(NERR,*)'INPUT DATA NOT IN SPECTRAL FORM' + CALL ABOR1('TRANSFORM_TEST:INPUT DATA NOT IN SPECTRAL FORM') + ENDIF + + CALL GRIB_GET(IGRIB(1),'pentagonalResolutionParameterJ',NSMAX) + +! Decide gridpoint resolution + + IF (NDGL == 0) THEN + CALL SETNDGL + ELSE + CALL CHECK_NDGL + ENDIF +ENDIF + +IF(NPROC > 1) THEN + CALL MPL_BROADCAST(NSMAX,KROOT=1,KTAG=ITAG, & + & CDSTRING='TRANSFORM_TEST:') + + CALL MPL_BROADCAST(NDGL,KROOT=1,KTAG=ITAG, & + & CDSTRING='TRANSFORM_TEST:') +ENDIF +ALLOCATE(NLOEN(NDGL)) + +IF(MYPROC == 1) THEN + + IF(NTYPE == 0) THEN + NLOEN(:) = 2*NDGL + ELSEIF(NQ == 1.AND.NTYPE == 1) THEN + ! cubic grid + ITABLE = INDEX(CRTABLE,' ') + IF(NSMAX < 1000) THEN + WRITE(CRTABLE(ITABLE:ITABLE+11),'(A,I3.3)') '/rtable_3',NSMAX + ELSE + WRITE(CRTABLE(ITABLE:ITABLE+12),'(A,I4.4)') '/rtable_3',NSMAX + ENDIF + ELSEIF(NQ == 2.AND.NTYPE == 1) THEN + ! cubic grid + Collignon + ITABLE = INDEX(CRTABLE,' ') + IF(NSMAX < 1000) THEN + WRITE(CRTABLE(ITABLE:ITABLE+11),'(A,I3.3)') '/rtable_4',NSMAX + ELSE + WRITE(CRTABLE(ITABLE:ITABLE+12),'(A,I4.4)') '/rtable_4',NSMAX + ENDIF + ELSEIF(NLIN == 0.AND.NTYPE == 1) THEN + ! quadratic grid + ITABLE = INDEX(CRTABLE,' ') + IF(NSMAX < 1000) THEN + WRITE(CRTABLE(ITABLE:ITABLE+11),'(A,I3.3)') '/rtable_2',NSMAX + ELSE + WRITE(CRTABLE(ITABLE:ITABLE+12),'(A,I4.4)') '/rtable_2',NSMAX + ENDIF + ELSEIF(NLIN == 1.AND.NTYPE == 1) THEN + ITABLE = INDEX(CRTABLE,' ') + IF(NSMAX < 1000) THEN + WRITE(CRTABLE(ITABLE:ITABLE+12),'(A,I3.3)') '/rtablel_2',NSMAX + ELSE + WRITE(CRTABLE(ITABLE:ITABLE+13),'(A,I4.4)') '/rtablel_2',NSMAX + ENDIF + ENDIF + IF(NTYPE == 1) THEN + OPEN(15,FILE=CRTABLE,FORM='FORMATTED',ACTION='READ') + READ(15,NAMRGRI) + NLOEN(:) = NRGRI(1:NDGL) + CLOSE(15) + ENDIF + + CALL GRIB_RELEASE(IGRIB(1)) + CALL GRIB_CLOSE_FILE(INSF) + +ENDIF + + +IF(NPROC > 1) THEN + CALL MPL_BROADCAST(NLOEN(:),KROOT=1,KTAG=ITAG, & + & CDSTRING='TRANSFORM_TEST:') +ENDIF + +CALL SETUP_TRANS0(KOUT=NOUT,KERR=NERR,KPRINTLEV=NPRINTLEV,KMAX_RESOL=NMAX_RESOL, & +& KPROMATR=NPROMATR,KPRGPNS=NPRGPNS,KPRGPEW=NPRGPEW,KPRTRW=NPRTRW, & +& KCOMBFLEN=NCOMBFLEN,LDMPOFF=LMPOFF,LDSYNC_TRANS=LSYNC_TRANS, & +& LDEQ_REGIONS=LEQ_REGIONS, & +& PRAD=ZRA,LDALLOPERM=.TRUE.) + +CALL SETUP_TRANS(KSMAX=NSMAX,KDGL=NDGL,KLOEN=NLOEN,LDSPLIT=.TRUE.,& +& KFLEV=NFLEVL, LDUSEFFTW=LFFTW,& +& LDUSERPNM=LUSERPNM,LDKEEPRPNM=LKEEPRPNM,LDUSEFLT=LUSEFLT) +! +CALL TRANS_INQ(KSPEC2=NSPEC2,KSPEC2G=NSPEC2G,KGPTOT=NGPTOT,KGPTOTG=NGPTOTG) +DO JB=D%NPTRFRSTLAT(MY_REGION_NS),D%NPTRLSTLAT(MY_REGION_NS) + WRITE(300+MYPROC,*) "MY_REGION", JB-D%NPTRFRSTLAT(MY_REGION_NS)+D%NFRSTLAT(MY_REGION_NS), D%NSTA(JB,MY_REGION_EW), D%NONL(JB,MY_REGION_EW) +ENDDO +IF (MYPROC == 1) THEN + DO JB=1,NDGL + WRITE(300+MYPROC,*) "LATITUDE", JB, ASIN(F%RMU(JB))/3.14159265358979323846264338327950288*180, NLOEN(JB) + ENDDO +ENDIF + + +! Default, no blocking +NPROMA=NGPTOT +! allow NPROMA to be overidden by namelist value +REWIND(NULNAM) +READ(NULNAM,NAMTRANS) +! Calculate number of NPROMA blocks +NGPBLKS=(NGPTOT-1)/NPROMA+1 + +! Allocate spectral arrays +! Try to mimick IFS layout as much as possible +NULLIFY(ZVOR) +NULLIFY(ZDIV) +NULLIFY(ZT) +ALLOCATE(SP3D(NFLEVL,NSPEC2,3)) +ALLOCATE(ZSP(1,NSPEC2)) + +SP3D(:,:,:)=0.0_JPRB +ZSP(:,:) =0.0_JPRB +ZVOR =>SP3D(:,:,1) +ZDIV =>SP3D(:,:,2) +ZT =>SP3D(:,:,3:3) + +! Spectral global buffers +! Allocating only on PE 1 +! Dangerous, but otherwise we run out of memory +! if we run flat MPI +IF(MYPROC == 1) THEN + ALLOCATE(ZFPDAT(NSPEC2G)) + ALLOCATE(ZSPVORG(NFLEVG,NSPEC2G)) + ALLOCATE(ZSPDIVG(NFLEVG,NSPEC2G)) + ALLOCATE(ZSPTG(NFLEVG,NSPEC2G,1)) + ALLOCATE(ZSPSPG(1,NSPEC2G)) +ENDIF + +! Open files +IF(MYPROC == 1) THEN + CALL GRIB_OPEN_FILE(INSF,CINSF,'R',IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*) 'ERROR OPENING FILE INPUT SPECTRAL FILE',CINSF,IRET + CALL ABOR1('TRANSFORM_TEST:ERROR OPENING FILE INPUT SPECTRAL FILE') + ENDIF +ENDIF + +! Spectral to gridpoint transform +LDONE = .FALSE. + +! specify the maximum number of fields to be read from input dataset +! it is not a problem if there are less fields as the actual number of fields +! that will transformed will be replicated from the actual number of fields read +IMAX_FLDS_IN=412 + +! allow IMAX_FLDS_IN to be overidden by namelist value +REWIND(NULNAM) +READ(NULNAM,NAMTRANS) + +! Inititialize GRIB_API handles to zero +IGRIB(:) = 0 +IGRIBOUT = 0 + +DO + IF(MYPROC == 1) THEN + + ! Read and decode spectral field +! WRITE(NOUT,*) ' CALLING GRIB_NEW_FROM_FILE' + CALL GRIB_NEW_FROM_FILE(INSF,IGRIB(1),IRET) + IF(IRET == GRIB_END_OF_FILE) THEN + LDONE = .TRUE. + WRITE(NOUT,'(A)') 'END OF GRIB FILE REACHED.' + ENDIF + + IF(IFLDS==IMAX_FLDS_IN) THEN + LDONE = .TRUE. + ENDIF + + IF(.NOT. LDONE) THEN + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*) 'ERROR GRIB_NEW_FROM_FILE',IRET + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_NEW_FROM_FILE') + ENDIF + + CALL GRIB_GET(IGRIB(1),'edition',IEDITION(1),IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'ERROR GRIB_GET edition' + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_GET edition') + ENDIF + + CALL GRIB_GET(IGRIB(1),'paramId',IPARAM(1),IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'ERROR GRIB_GET paramId' + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_GET paramId') + ENDIF + + ! Write out "skipped field" to output spectral file + IF(IPARAM(1) /= ICODE.AND.ICODE /= 0) THEN + PRINT *,'FIELD ',IPARAM(1),' NOT TRANSFORMED' + CALL GRIB_CLONE(IGRIB(1),IGRIBOUT,IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'TRANSFORM_TEST:ERROR GRIB_CLONE' + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_CLONE') + ENDIF + CALL GRIB_WRITE(IGRIBOUT,IOUTSF,IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'TRANSFORM_TEST:ERROR GRIB_WRITE' + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_WRITE') + ENDIF + CALL GRIB_RELEASE(IGRIBOUT) + CYCLE + ENDIF + + CALL GRIB_GET(IGRIB(1),'level',ICURLEV,IRET) + IF( IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'ERROR GRIB_GET level' + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_GET level') + ENDIF + + CALL GRIB_GET(IGRIB(1),'shortName',CFNAME,IRET) + IF( IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'ERROR GRIB_GET shortName' + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_GET shortName') + ENDIF + + CALL GRIB_GET(IGRIB(1),'values',ZFPDAT,IRET) + IF(IRET /= GRIB_SUCCESS) THEN + WRITE(NERR,*)'ERROR GRIB_GET values ',IRET + CALL ABOR1('TRANSFORM_TEST:ERROR GRIB_GET values') + ENDIF + CALL GRIB_RELEASE(IGRIB(1)) + IFLD=1 + ILEV=ICURLEV(1) + ILASTLEV = MAX(ILEV,ILASTLEV) + + IF( CFNAME == 'lnsp' ) THEN + ZSPSPG(1,:)=ZFPDAT(:) + IFLDS=IFLDS+1 + ENDIF + + IF( CFNAME == 'vo' ) THEN + ZSPVORG(ILEV,:)=ZFPDAT(:) + IFLDS=IFLDS+1 + ENDIF + + IF( CFNAME == 'd' ) THEN + ZSPDIVG(ILEV,:)=ZFPDAT(:) + IFLDS=IFLDS+1 + ENDIF + + IF( CFNAME == 't' ) THEN + ZSPTG(ILEV,:,1)=ZFPDAT(:) + IFLDS=IFLDS+1 + ENDIF + ENDIF + ! Send number of fields in this batch to other processors + IF(NPROC > 1) THEN + DO JROC=2,NPROC + CALL MPL_SEND(IFLD,KDEST=NPRCIDS(JROC),KTAG=ITAG) + ENDDO + ENDIF + + ELSE + ! Receive field + CALL MPL_RECV(IFLD,KSOURCE=NPRCIDS(1),KTAG=ITAG) + ENDIF + + IF(NPROC > 1 .AND. IFLD == 1) THEN + CALL MPL_BROADCAST(IPARAM(IFLD),KROOT=1,KTAG=ITAG, & + & CDSTRING='TRANSFORM_TEST:') + ENDIF + IF(IFLD == 0 ) EXIT + + ! Synchronize processors + IF(NPROC > 1) THEN + CALL MPL_BARRIER() + ENDIF +! Distribute batch of fields + + IFLD = 0 +ENDDO + + +IF (MYPROC == 1) THEN + CALL GRIB_CLOSE_FILE(INSF) +ENDIF + +! Broadcast number of fields read to all procs and levels +IF(NPROC > 1) THEN + CALL MPL_BROADCAST(IFLDS,KROOT=1,KTAG=ITAG, & + & CDSTRING='TRANSFORM_TEST:') + CALL MPL_BROADCAST(ILASTLEV,KROOT=1,KTAG=ITAG, & + & CDSTRING='TRANSFORM_TEST:') + +ENDIF + +! Some sanity checks +IF( ILASTLEV < 1 ) CALL ABOR1('TRANSFORM_TEST:ILASTLEV < 1') +IF( NFLEVG < ILASTLEV ) CALL ABOR1('TRANSFORM_TEST:NFLEVG < ILASTLEV') + +! Extend fields using mod function +IF( NFLEVG > ILASTLEV ) THEN + IF( MYPROC == 1 ) THEN + DO ILEV=ILASTLEV+1,NFLEVG + ZSPVORG(ILEV,:) = ZSPVORG(MOD(ILEV-1,ILASTLEV)+1,:) + ZSPDIVG(ILEV,:) = ZSPDIVG(MOD(ILEV-1,ILASTLEV)+1,:) + ZSPTG(ILEV,:,1) = ZSPTG(MOD(ILEV-1,ILASTLEV)+1,:,1) + ENDDO + ENDIF +ENDIF + +WRITE(NOUT,'(" ")') +WRITE(NOUT,'("SPECTRAL FIELDS HAVE BEEN SUCCESSFULY READ, IFLDS=",I3)')IFLDS +WRITE(NOUT,'(" ")') + +! PRINT CONFIGURATION DETAILS +WRITE(NOUT,'(A)')'===-=== START OF RUNTIME PARAMETERS ===-===' +WRITE(NOUT,'(" ")') +WRITE(NOUT,'("NLIN= ",I10)') NLIN +WRITE(NOUT,'("NQ= ",I10)') NQ +WRITE(NOUT,'("NSMAX= ",I10)') NSMAX +WRITE(NOUT,'("NDGL= ",I10)') NDGL +WRITE(NOUT,'("NPROC= ",I10)') NPROC +WRITE(NOUT,'("NTHREAD=",I10)') NTHREAD +WRITE(NOUT,'("NPRGPNS=",I10)') NPRGPNS +WRITE(NOUT,'("NPRGPEW=",I10)') NPRGPEW +WRITE(NOUT,'("NPRTRW= ",I10)') NPRTRW +WRITE(NOUT,'("NPRTRV= ",I10)') NPRTRV +WRITE(NOUT,'("NPROMA= ",I10)') NPROMA +WRITE(NOUT,'("NGPTOT= ",I10)') NGPTOT +WRITE(NOUT,'("NGPTOTG=",I10)') NGPTOTG +WRITE(NOUT,'("NFLEVG= ",I10)') NFLEVG +WRITE(NOUT,'("IFLDS= ",I10)') IFLDS +WRITE(NOUT,'("NSPEC2= ",I10)') NSPEC2 +WRITE(NOUT,'("NSPEC2G=",I10)') NSPEC2G +WRITE(NOUT,'("LUSEFLT=",L10)') LUSEFLT +WRITE(NOUT,'(" ")') +WRITE(NOUT,'(A)') '===-=== END OF RUNTIME PARAMETERS ===-===' + + +ALLOCATE(IVSET(NFLEVG)) + +! Compute spectral distribution +ILEV = 0 +DO JB=1,NPRTRV + DO JLEV=1,NUMLL(JB) + ILEV = ILEV + 1 + IVSET(ILEV) = JB + ENDDO +ENDDO + +ALLOCATE(ITO(IFLDS)) +ITO(:)=1 + +! Distribute spectral fields to processors +CALL DIST_SPEC(PSPECG=ZSPVORG,KFDISTG=NFLEVG,KFROM=ITO,PSPEC=ZVOR,KVSET=IVSET(1:NFLEVG)) +CALL DIST_SPEC(PSPECG=ZSPDIVG,KFDISTG=NFLEVG,KFROM=ITO,PSPEC=ZDIV,KVSET=IVSET(1:NFLEVG)) +CALL DIST_SPEC(PSPECG=ZSPTG(:,:,1),KFDISTG=NFLEVG,KFROM=ITO,PSPEC=ZT(:,:,1),KVSET=IVSET(1:NFLEVG)) +CALL DIST_SPEC(PSPECG=ZSPSPG,KFDISTG=1,KFROM=ITO,PSPEC=ZSP,KVSET=IVSETSC(1:1)) + +! Deallocate resources +IF(MYPROC==1) THEN + DEALLOCATE(ZFPDAT,ITO) + DEALLOCATE(ZSPVORG,ZSPDIVG,ZSPTG,ZSPSPG) +ENDIF +! ALLOCATE GRID-POINT ARRAYS +ALLOCATE(ZWINDS(NPROMA,NFLEVG,6,NGPBLKS)) +ALLOCATE(ZGMV(NPROMA,NFLEVG,NDIMGMV,NGPBLKS)) +ALLOCATE(ZGMVS(NPROMA,NDIMGMVS,NGPBLKS)) + +ALLOCATE(ZNORMSP(1)) +ALLOCATE(ZNORMSP1(1)) +ALLOCATE(ZNORMVOR(NFLEVG)) +ALLOCATE(ZNORMVOR1(NFLEVG)) +ALLOCATE(ZNORMDIV(NFLEVG)) +ALLOCATE(ZNORMDIV1(NFLEVG)) +ALLOCATE(ZNORMT(NFLEVG)) +ALLOCATE(ZNORMT1(NFLEVG)) + +IF( NPRINTNORMS > 0 ) THEN + CALL SPECNORM(PSPEC=ZVOR(1:NFLEVL,:),PNORM=ZNORMVOR1,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZDIV(1:NFLEVL,:),PNORM=ZNORMDIV1,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZT(1:NFLEVL,:,1),PNORM=ZNORMT1,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZSP(1:1,:), PNORM=ZNORMSP1,KVSET=IVSETSC(1:1)) + + IF(MYPROC == 1) THEN + DO IFLD=1,1 + WRITE(NOUT,'("SP ZNORM(",I4,")=",F20.15)') IFLD,ZNORMSP1(IFLD) + ENDDO + DO IFLD=1,NFLEVG + WRITE(NOUT,'("DIV ZNORM(",I4,")=",F20.15)') IFLD,ZNORMDIV1(IFLD) + ENDDO + DO IFLD=1,NFLEVG + WRITE(NOUT,'("VOR ZNORM(",I4,")=",F20.15)') IFLD,ZNORMVOR1(IFLD) + ENDDO + DO IFLD=1,NFLEVG + WRITE(NOUT,'("T ZNORM(",I4,")=",F20.15)') IFLD,ZNORMT1(IFLD) + ENDDO + ENDIF +ENDIF + +ZTINIT=(TIMEF()-ZTINIT)/1000.0_JPRD +WRITE(NOUT,'(" ")') +WRITE(NOUT,'(a,I6,a,F9.2,a)') "TRANSFORM_TEST initialisation, on",NPROC,& + & " tasks, took",ZTINIT," sec" +WRITE(NOUT,'(" ")') + +IF(ITERS<=0) CALL ABOR1('TRANSFORM_TEST:ITERS <= 0') + +ALLOCATE(ZTSTEP(ITERS)) +ALLOCATE(ZTSTEP1(ITERS)) +ALLOCATE(ZTSTEP2(ITERS)) + +ZTSTEPAVG=0._JPRD +ZTSTEPMAX=0._JPRD +ZTSTEPMIN=9999999999999999._JPRD +ZTSTEPAVG1=0._JPRD +ZTSTEPMAX1=0._JPRD +ZTSTEPMIN1=9999999999999999._JPRD +ZTSTEPAVG2=0._JPRD +ZTSTEPMAX2=0._JPRD +ZTSTEPMIN2=9999999999999999._JPRD + +WRITE(NOUT,'(A)') '===-=== START OF SPEC TRANSFORMS ===-===' +WRITE(NOUT,'(" ")') + +IF( LSTATS ) THEN + CALL GSTATS(0,0) + CALL GSTATS_SETUP(NPROC,MYPROC,NPRCIDS,& + & LSTATS,LSTATSCPU,LSYNCSTATS,LDETAILED_STATS,LBARRIER_STATS,LBARRIER_STATS2,& + & LSTATS_OMP,LSTATS_COMMS,LSTATS_MEM,NSTATS_MEM,LSTATS_ALLOC,& + & LTRACE_STATS,NTRACE_STATS,NPRNT_STATS,LXML_STATS) + CALL GSTATS_PSUT + CALL GSTATS_LABEL_IFS +ENDIF + +ZTLOOP=TIMEF() +! simulated time stepping loop + +!skip time measurements for first iteration +YLSTATS = .false. + +DO JSTEP=1,1 + IF (JSTEP > 1) YLSTATS = .true. + ZTSTEP(JSTEP)=TIMEF() + ZTSTEP1(JSTEP)=TIMEF() + + ! scalar parts only + JJSTEP = 1 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPSC2=ZSP(1:1,:),PSPSC3A=ZT,& + & PGP2=ZGMVS(:,1:3,:),PGP3A=ZGMV(:,:,5:7,:), & + & LDSCDERS=.TRUE.,LDVORGP=.FALSE.,LDDIVGP=.FALSE.,LDUVDER=.FALSE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZGMV(:,:,:,:), 'M', NOUTDUMP) + + ! all; split, all options on + JJSTEP = 2 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPVOR=ZVOR,PSPDIV=ZDIV,PSPSC2=ZSP(1:1,:),PSPSC3A=ZT,& + & PGPUV=ZWINDS(:,:,1:4,:),PGP2=ZGMVS(:,1:3,:),PGP3A=ZGMV(:,:,5:7,:),& + & LDSCDERS=.TRUE.,LDVORGP=.TRUE.,LDDIVGP=.TRUE.,LDUVDER=.FALSE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZWINDS(:,:,:,:), 'W', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZGMV(:,:,:,:), 'M', NOUTDUMP) + + ! only wind + JJSTEP = 3 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPVOR=ZVOR,PSPDIV=ZDIV,& + & PGPUV=ZWINDS(:,:,3:4,:),& + & LDVORGP=.FALSE.,LDDIVGP=.false.,LDUVDER=.FALSE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZWINDS(:,:,:,:), 'W', NOUTDUMP) + + ! all; split + JJSTEP = 4 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPVOR=ZVOR,PSPDIV=ZDIV,PSPSC2=ZSP(1:1,:),PSPSC3A=ZT,& + & PGPUV=ZWINDS(:,:,2:4,:),PGP2=ZGMVS(:,1:3,:),PGP3A=ZGMV(:,:,5:7,:),& + & LDSCDERS=.TRUE.,LDVORGP=.FALSE.,LDDIVGP=.TRUE.,LDUVDER=.FALSE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZWINDS(:,:,:,:), 'W', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZGMV(:,:,:,:), 'M', NOUTDUMP) + + ! scalar only; with derivatives + JJSTEP = 5 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPSCALAR=ZSP(1:1,:),& + & PGP=ZGMVS(:,1:3,:), & + & LDSCDERS=.TRUE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETSC=IVSETSC(1:1)) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + + ! scalar only + JJSTEP = 6 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPSCALAR=ZSP(1:1,:),& + & PGP=ZGMVS(:,1:1,:),& + & KRESOL=1,KPROMA=NPROMA,KVSETSC=IVSETSC(1:1)) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + + ! scalar split only + JJSTEP = 7 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPSC2=ZSP(1:1,:),& + & PGP2=ZGMVS(:,1:3,:),& + & LDSCDERS=.TRUE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSETSC(1:1)) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZGMVS(:,:,:), 'S', NOUTDUMP) + + ! scalar split only; with derivatives + JJSTEP = 8 + ZGMVS = 0 + ZWINDS = 0 + ZGMV = 0 + CALL INV_TRANS(PSPSC2=ZT(:,:,1),& + & PGP2=ZGMV(:,:,5,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSET) + CALL DUMP_GRIDPOINT_FIELD_4D(JJSTEP, MYPROC, ZGMV(:,:,:,:), 'M', NOUTDUMP) + + ZTSTEP1(JSTEP)=(TIMEF()-ZTSTEP1(JSTEP))/1000.0_JPRD + ZTSTEP2(JSTEP)=TIMEF() + + CALL INV_TRANS(PSPVOR=ZVOR,PSPDIV=ZDIV,PSPSC2=ZSP(1:1,:),PSPSC3A=ZT,& + & PGPUV=ZWINDS(:,:,1:4,:),PGP2=ZGMVS(:,1:3,:),PGP3A=ZGMV(:,:,5:7,:),& + & LDSCDERS=.TRUE.,LDVORGP=.TRUE.,LDDIVGP=.TRUE.,LDUVDER=.FALSE.,& + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET) + + JJSTEP = 9 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPSCALAR=ZSP(1:1,:), & + & PGP=ZGMVS(:,1:1,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETSC=IVSETSC(1:1)) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZSP(:,:), 'P', NOUTDUMP) + + JJSTEP = 10 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPSC2=ZSP(1:1,:),PSPSC3A=ZT,& + & PGP2=ZGMVS(:,1:1,:),PGP3A=ZGMV(:,:,5:5,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZSP(:,:), 'P', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZT(:,:,:), 'T', NOUTDUMP) + + JJSTEP = 11 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPVOR=ZVOR(1:NFLEVL,:),PSPDIV=ZDIV(1:NFLEVL,:),& + & PGPUV=ZWINDS(:,1:NFLEVG,3:4,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET(1:NFLEVG)) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZVOR(:,:), 'V', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZDIV(:,:), 'D', NOUTDUMP) + + JJSTEP = 12 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPSC2=ZSP(1:1,:),& + & PGP2=ZGMVS(:,1:1,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSETSC(1:1)) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZSP(:,:), 'P', NOUTDUMP) + + JJSTEP = 13 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPSC2=ZT(:,:,1),& + & PGP2=ZGMV(:,:,5,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSET) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZT(:,:,:), 'T', NOUTDUMP) + + JJSTEP = 14 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPSC2=ZSP(1:1,:),PSPSC3A=ZT(:,:,:),& + & PGP2=ZGMVS(:,1:1,:),PGP3A=ZGMV(:,:,5:5,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET(:)) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZSP(:,:), 'P', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZT(:,:,:), 'T', NOUTDUMP) + + JJSTEP = 16 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPVOR=ZVOR(:,:),PSPDIV=ZDIV(:,:),& + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET(:),& + & PGPUV=ZWINDS(:,:,3:4,:)) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZVOR(:,:), 'V', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZDIV(:,:), 'D', NOUTDUMP) + + JJSTEP = 17 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPSCALAR=ZSP(1:1,:),PGP=ZGMVS(:,1:1,:),KVSETSC=IVSETSC(1:1),& + & KPROMA=NPROMA) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZSP(:,:), 'V', NOUTDUMP) + + JJSTEP = 15 + ZSP = 0 + ZT = 0 + ZVOR = 0 + ZDIV = 0 + CALL DIR_TRANS(PSPVOR=ZVOR,PSPDIV=ZDIV,PSPSC2=ZSP(1:1,:),PSPSC3A=ZT,& + & PGPUV=ZWINDS(:,:,3:4,:),PGP2=ZGMVS(:,1:1,:),PGP3A=ZGMV(:,:,5:5,:), & + & KRESOL=1,KPROMA=NPROMA,KVSETUV=IVSET,KVSETSC2=IVSETSC(1:1),& + & KVSETSC3A=IVSET) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZVOR(:,:), 'V', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZDIV(:,:), 'D', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_2D(JJSTEP, MYPROC, ZSP(:,:), 'P', NOUTDUMP) + CALL DUMP_GRIDPOINT_FIELD_3D(JJSTEP, MYPROC, ZT(:,:,:), 'T', NOUTDUMP) + + ZTSTEP2(JSTEP)=(TIMEF()-ZTSTEP2(JSTEP))/1000.0_JPRD + + ZTSTEP(JSTEP)=(TIMEF()-ZTSTEP(JSTEP))/1000.0_JPRD + + ZTSTEPAVG=ZTSTEPAVG+ZTSTEP(JSTEP) + ZTSTEPMIN=MIN(ZTSTEP(JSTEP),ZTSTEPMIN) + ZTSTEPMAX=MAX(ZTSTEP(JSTEP),ZTSTEPMAX) + + ZTSTEPAVG1=ZTSTEPAVG1+ZTSTEP1(JSTEP) + ZTSTEPMIN1=MIN(ZTSTEP1(JSTEP),ZTSTEPMIN1) + ZTSTEPMAX1=MAX(ZTSTEP1(JSTEP),ZTSTEPMAX1) + + ZTSTEPAVG2=ZTSTEPAVG2+ZTSTEP2(JSTEP) + ZTSTEPMIN2=MIN(ZTSTEP2(JSTEP),ZTSTEPMIN2) + ZTSTEPMAX2=MAX(ZTSTEP2(JSTEP),ZTSTEPMAX2) + + + IF( NPRINTNORMS > 1 )THEN + CALL SPECNORM(PSPEC=ZSP(1:1,:), PNORM=ZNORMSP, KVSET=IVSETSC(1:1)) + CALL SPECNORM(PSPEC=ZVOR(1:NFLEVL,:), PNORM=ZNORMVOR,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZDIV(1:NFLEVL,:), PNORM=ZNORMDIV,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZT(1:NFLEVL,:,1), PNORM=ZNORMT, KVSET=IVSET(1:NFLEVG)) + + IF( MYPROC==1 ) THEN + ! SURFACE PRESSURE + ZMAXERR(:)=-999.0 + DO IFLD=1,1 + ZERR(1)=ABS(ZNORMSP1(IFLD)/ZNORMSP(IFLD)-1.0_JPRB) + ZMAXERR(1)=MAX(ZMAXERR(1),ZERR(1)) + ENDDO + ! DIVERGENCE + DO IFLD=1,NFLEVG + ZERR(2)=ABS(ZNORMDIV1(IFLD)/ZNORMDIV(IFLD)-1.0_JPRB) + ZMAXERR(2)=MAX(ZMAXERR(2),ZERR(2)) + ENDDO + ! VORTICITY + DO IFLD=1,NFLEVG + ZERR(3)=ABS(ZNORMVOR1(IFLD)/ZNORMVOR(IFLD)-1.0_JPRB) + ZMAXERR(3)=MAX(ZMAXERR(3),ZERR(3)) + ENDDO + ! TEMPERATURE + DO IFLD=1,NFLEVG + ZERR(4)=ABS(ZNORMT1(IFLD)/ZNORMT(IFLD)-1.0_JPRB) + ZMAXERR(4)=MAX(ZMAXERR(4),ZERR(4)) + ENDDO + WRITE(NOUT,'("time step ",I6," took", F8.4," | SP max err="E10.3,& + & " | DIV max err="E10.3," | VOR max err="E10.3," | T max err="E10.3)') & + & JSTEP,ZTSTEP(JSTEP),ZMAXERR(1),ZMAXERR(2),ZMAXERR(3),ZMAXERR(4) + ENDIF + ELSE + WRITE(NOUT,'("time step ",I6," took", F8.4)') JSTEP,ZTSTEP(JSTEP) + ENDIF + flush(nout) + ! call acc_present_dump() + ! print *, "going to free in 3 seconds" + ! call sleep (1) + ! print *, "going to free in 2 seconds" + ! call sleep (1) + ! print *, "going to free in 1 seconds" + ! call sleep (1) + ! !call acc_clear_freelists() + ! call sleep (5) + ! !call acc_present_dump() + ! !call sleep (10000) +ENDDO + +ZTLOOP=(TIMEF()-ZTLOOP)/1000.0_JPRD + +WRITE(NOUT,'(" ")') +WRITE(NOUT,'(A)') '===-=== END OF SPEC TRANSFORMS ===-===' +WRITE(NOUT,'(" ")') + + +IF( NPRINTNORMS > 0 ) THEN + CALL SPECNORM(PSPEC=ZVOR(1:NFLEVL,:),PNORM=ZNORMVOR,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZDIV(1:NFLEVL,:),PNORM=ZNORMDIV,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZT(1:NFLEVL,:,1),PNORM=ZNORMT,KVSET=IVSET(1:NFLEVG)) + CALL SPECNORM(PSPEC=ZSP(1:1,:), PNORM=ZNORMSP,KVSET=IVSETSC(1:1)) + + IF(MYPROC == 1) THEN + ! SURFACE PRESSURE + ZMAXERR(:)=-999.0 + DO IFLD=1,1 + ZERR(1)=ABS(ZNORMSP1(IFLD)/ZNORMSP(IFLD)-1.0D0) + ZMAXERR(1)=MAX(ZMAXERR(1),ZERR(1)) + WRITE(NOUT,'("SP ZNORM(",I4,")=",F20.15," ERR=",E10.3)') IFLD,ZNORMSP(IFLD),ZERR(1) + ENDDO + ! DIVERGENCE + DO IFLD=1,NFLEVG + ZERR(2)=ABS(ZNORMDIV1(IFLD)/ZNORMDIV(IFLD)-1.0D0) + ZMAXERR(2)=MAX(ZMAXERR(2),ZERR(2)) + WRITE(NOUT,'("DIV ZNORM(",I4,")=",F20.15," ERR=",E10.3)') IFLD,ZNORMDIV(IFLD),ZERR(2) + ENDDO + ! VORTICITY + DO IFLD=1,NFLEVG + ZERR(3)=ABS(ZNORMVOR1(IFLD)/ZNORMVOR(IFLD)-1.0D0) + ZMAXERR(3)=MAX(ZMAXERR(3),ZERR(3)) + WRITE(NOUT,'("VOR ZNORM(",I4,")=",F20.15," ERR=",E10.3)') IFLD,ZNORMVOR(IFLD),ZERR(3) + ENDDO + ! TEMPERATURE + DO IFLD=1,NFLEVG + ZERR(4)=ABS(ZNORMT1(IFLD)/ZNORMT(IFLD)-1.0D0) + ZMAXERR(4)=MAX(ZMAXERR(4),ZERR(4)) + WRITE(NOUT,'("T ZNORM(",I4,")=",F20.15," ERR=",E10.3)') IFLD,ZNORMT(IFLD),ZERR(4) + ENDDO + ! MAXIMUM ERROR ACROSS ALL FIELDS + ZMAXERRG=MAX(MAX(ZMAXERR(1),ZMAXERR(2)),MAX(ZMAXERR(2),ZMAXERR(3))) + + WRITE(NOUT,'("SURFACE PRESSURE MAX ERROR=",E10.3)')ZMAXERR(1) + WRITE(NOUT,'("DIVERGENCE MAX ERROR=",E10.3)')ZMAXERR(2) + WRITE(NOUT,'("VORTICITY MAX ERROR=",E10.3)')ZMAXERR(3) + WRITE(NOUT,'("TEMPERATURE MAX ERROR=",E10.3)')ZMAXERR(4) + WRITE(NOUT,'("GLOBAL MAX ERROR=",E10.3)')ZMAXERRG + + ENDIF +ENDIF + +CALL MPL_ALLREDUCE(ZTLOOP, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEP, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPAVG, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPMAX, 'MAX', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPMIN, 'MIN', LDREPROD=.FALSE.) + +CALL MPL_ALLREDUCE(ZTSTEP1, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPAVG1, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPMAX1, 'MAX', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPMIN1, 'MIN', LDREPROD=.FALSE.) + +CALL MPL_ALLREDUCE(ZTSTEP2, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPAVG2, 'SUM', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPMAX2, 'MAX', LDREPROD=.FALSE.) +CALL MPL_ALLREDUCE(ZTSTEPMIN2, 'MIN', LDREPROD=.FALSE.) + + +ZTSTEPAVG=(ZTSTEPAVG/REAL(NPROC,JPRB))/REAL(ITERS,JPRD) +ZTLOOP=ZTLOOP/REAL(NPROC,JPRD) +ZTSTEP(:)=ZTSTEP(:)/REAL(NPROC,JPRD) + +CALL SORT(ZTSTEP,ITERS) +ZTSTEPMED = ZTSTEP(ITERS/2) + +ZTSTEPAVG1=(ZTSTEPAVG1/REAL(NPROC,JPRB))/REAL(ITERS,JPRD) +ZTSTEP1(:)=ZTSTEP1(:)/REAL(NPROC,JPRD) + +CALL SORT(ZTSTEP1,ITERS) +ZTSTEPMED1 = ZTSTEP1(ITERS/2) + +ZTSTEPAVG2=(ZTSTEPAVG2/REAL(NPROC,JPRB))/REAL(ITERS,JPRD) +ZTSTEP2(:)=ZTSTEP2(:)/REAL(NPROC,JPRD) + +CALL SORT(ZTSTEP2,ITERS) +ZTSTEPMED2 = ZTSTEP2(ITERS/2) + +IF(MYPROC == 1)THEN + WRITE(NOUT,'(" ")') + WRITE(NOUT,'(A)') '===-=== START OF TIME STEP STATS ===-===' + WRITE(NOUT,'(" ")') + WRITE(NOUT,'("INVERSE TRANSFORMS")') + WRITE(NOUT,'("------------------")') + WRITE(NOUT,'("AVG (s): ",F8.4)') ZTSTEPAVG1 + WRITE(NOUT,'("MIN (s): ",F8.4)') ZTSTEPMIN1 + WRITE(NOUT,'("MAX (s): ",F8.4)') ZTSTEPMAX1 + WRITE(NOUT,'("MED (s): ",F8.4)') ZTSTEPMED1 + WRITE(NOUT,'(" ")') + WRITE(NOUT,'("DIRECT TRANSFORMS")') + WRITE(NOUT,'("-----------------")') + WRITE(NOUT,'("AVG (s): ",F8.4)') ZTSTEPAVG2 + WRITE(NOUT,'("MIN (s): ",F8.4)') ZTSTEPMIN2 + WRITE(NOUT,'("MAX (s): ",F8.4)') ZTSTEPMAX2 + WRITE(NOUT,'("MED (s): ",F8.4)') ZTSTEPMED2 + WRITE(NOUT,'(" ")') + WRITE(NOUT,'("INVERSE-DIRECT TRANSFORMS")') + WRITE(NOUT,'("-------------------------")') + WRITE(NOUT,'("AVG (s): ",F8.4)') ZTSTEPAVG + WRITE(NOUT,'("MIN (s): ",F8.4)') ZTSTEPMIN + WRITE(NOUT,'("MAX (s): ",F8.4)') ZTSTEPMAX + WRITE(NOUT,'("MED (s): ",F8.4)') ZTSTEPMED + WRITE(NOUT,'("LOOP (s): ",F8.4)') ZTLOOP + WRITE(NOUT,'(" ")') + WRITE(NOUT,'(A)') '===-=== END OF TIME STEP STATS ===-===' + WRITE(NOUT,'(" ")') +ENDIF + +IF( LSTACK ) THEN +! gather stack usage statistics + ISTACK = GETSTACKUSAGE() + IF(MYPROC == 1) THEN + PRINT 9000, istack + 9000 FORMAT("Stack Utilisation Information",/,& + &"=============================",//,& + &"Task Size(Bytes)",/,& + &"==== ===========",//,& + &" 1",11x,I10) + + DO I=2,NPROC + CALL MPL_RECV(ISTACK,KSOURCE=NPRCIDS(I),KTAG=I, & + & CDSTRING='TRANSFORM_TEST:') + PRINT '(I4,11X,I10)', I,ISTACK + ENDDO + ELSE + CALL MPL_SEND(ISTACK,KDEST=NPRCIDS(1),KTAG=MYPROC, & + & CDSTRING='TRANSFORM_TEST:') + ENDIF +ENDIF + + +!-------------------------- +IF( LSTATS ) THEN + CALL GSTATS(0,1) + CALL GSTATS_PRINT(NOUT,ZAVEAVE,JPMAXSTAT) +ENDIF +!-------------------------- + +! CLOSE FILE +IF( NPROC > 1 ) THEN + IF( MYPROC /= 1 ) THEN + CLOSE(UNIT=NOUT) + ENDIF +ENDIF + +DEALLOCATE(ZWINDS) +DEALLOCATE(ZGMV) +DEALLOCATE(ZGMVS) + +!-------------------------- +CALL MPL_BARRIER() +CALL MPL_END() +!-------------------------- + + + + +CONTAINS + +! ------------------------------------------------------------------ + +SUBROUTINE SETNDGL + +! Decide number of Gaussian latitudes given spectral truncation +! Only certain combinations of truncation/linear grid +! or quadratic grid are supported + +! +! See prepdata/programs/sptogp.F90 +! + +IF(NLIN == 0 .AND. (NQ == 1.OR.NQ == 2)) THEN + IF(NSMAX == 79) THEN + NDGL = 160 + ELSEIF(NSMAX == 95) THEN + NDGL = 192 + ELSEIF(NSMAX == 127) THEN + NDGL = 256 + ELSEIF(NSMAX == 159) THEN + NDGL = 320 + ELSEIF(NSMAX == 199) THEN + NDGL = 400 + ELSEIF(NSMAX == 255) THEN + NDGL = 512 + ELSEIF(NSMAX == 319) THEN + NDGL = 640 + ELSEIF(NSMAX == 399) THEN + NDGL = 800 + ELSEIF(NSMAX == 511) THEN + NDGL = 1024 + ELSEIF(NSMAX == 639) THEN + NDGL = 1280 + ELSEIF(NSMAX == 799) THEN + NDGL = 1600 + ELSEIF(NSMAX == 1023) THEN + NDGL = 2048 + ELSEIF(NSMAX == 1279) THEN + NDGL = 2560 + ELSEIF(NSMAX == 1599) THEN + NDGL = 3200 + ELSEIF(NSMAX == 1999) THEN + NDGL = 4000 + ELSEIF(NSMAX == 3999) THEN + NDGL = 8000 + ELSEIF(NSMAX == 7999) THEN + NDGL = 16000 + ELSE + WRITE(NERR,*)'WRONG SPECTRAL RESOLUTION ',NSMAX,' CUBIC GRID' + CALL ABOR1('TRANSFORM_TEST:UNSUPPORTED SPECTRAL RESOLUTION - CUBIC GRID ') + ENDIF +ELSEIF (NLIN == 0) THEN + IF(NSMAX == 21) THEN + NDGL = 32 + ELSEIF(NSMAX == 42) THEN + NDGL = 64 + ELSEIF(NSMAX == 63) THEN + NDGL = 96 + ELSEIF(NSMAX == 106) THEN + NDGL = 160 + ELSEIF(NSMAX == 213) THEN + NDGL = 320 + ELSEIF(NSMAX == 341) THEN + NDGL = 512 + ELSEIF(NSMAX == 426) THEN + NDGL = 640 + ELSEIF(NSMAX == 533) THEN + NDGL = 800 + ELSEIF(NSMAX == 682) THEN + NDGL = 1024 + ELSEIF(NSMAX == 853) THEN + NDGL = 1280 + ELSEIF(NSMAX == 1364) THEN + NDGL = 2048 + ELSEIF(NSMAX == 1706) THEN + NDGL = 2560 + ELSE + WRITE(NERR,*)'WRONG SPECTRAL RESOLUTION ',NSMAX,' QUAD. GRID' + CALL ABOR1('TRANSFORM_TEST:UNSUPPORTED SPECTRAL RESOLUTION - QUAD. GRID ') + ENDIF +ELSEIF(NLIN == 1) THEN + IF(NSMAX == 63) THEN + NDGL = 64 + ELSEIF(NSMAX == 95) THEN + NDGL = 96 + ELSEIF(NSMAX == 127) THEN + NDGL = 128 + ELSEIF(NSMAX == 159) THEN + NDGL = 160 + ELSEIF(NSMAX == 191) THEN + NDGL = 192 + ELSEIF(NSMAX == 199) THEN + NDGL = 200 + ELSEIF(NSMAX == 255) THEN + NDGL = 256 + ELSEIF(NSMAX == 319) THEN + NDGL = 320 + ELSEIF(NSMAX == 399) THEN + NDGL = 400 + ELSEIF(NSMAX == 511) THEN + NDGL = 512 + ELSEIF(NSMAX == 639) THEN + NDGL = 640 + ELSEIF(NSMAX == 799) THEN + NDGL = 800 + ELSEIF(NSMAX == 1023) THEN + NDGL = 1024 + ELSEIF(NSMAX == 1279) THEN + NDGL = 1280 + ELSEIF(NSMAX == 2047) THEN + NDGL = 2048 + ELSEIF(NSMAX == 3999) THEN + NDGL = 4000 + ELSEIF(NSMAX == 7999) THEN + NDGL = 8000 + ELSE + WRITE(NERR,*)'WRONG SPECTRAL RESOLUTION ',NSMAX,' LIN. GRID' + CALL ABOR1('TRANSFORM_TEST:UNSUPPORTED SPECTRAL RESOLUTION - LIN. GRID') + ENDIF +ELSE + WRITE(NERR,*)'WRONG NLIN=',NLIN + CALL ABOR1('TRANSFORM_TEST:WRONG NLIN') +ENDIF +END SUBROUTINE SETNDGL + +! ------------------------------------------------------------------ + +SUBROUTINE CHECK_NDGL + +! Decide number of Gaussian latitudes given spectral truncation +! Only certain combinations of truncation/linear grid +! or quadratic grid are supported + +IF(NLIN == 0) THEN + IF(NDGL .ne. 32 .and. NDGL .ne. 64 .and. NDGL .ne. 96 .and. & + NDGL .ne. 160 .and. NDGL .ne. 320 .and. NDGL .ne. 512 .and. & + NDGL .ne. 640 .and. NDGL .ne. 800 .and. NDGL .ne. 1024 .and. NDGL .ne. 1280 ) THEN + WRITE(NERR,*)'WRONG SPECTRAL RESOLUTION ',NSMAX,' QUAD. GRID' +! CALL ABOR1('TRANSFORM_TEST:UNSUPPORTED SPECTRAL RESOLUTION - QUAD. GRID ') + ENDIF +ELSEIF(NLIN == 1) THEN + IF(NDGL .ne. 32 .and. NDGL .ne. 64 .and. NDGL .ne. 96 .and. NDGL .ne. 128 .and. & + NDGL .ne. 160.and. NDGL .ne. 256 .and. NDGL .ne. 320 .and. NDGL .ne. 400 .and. & + NDGL .ne. 512.and. NDGL .ne. 640 .and. NDGL .ne. 800 .and. NDGL .ne. 1024) THEN + WRITE(NERR,*)'WRONG SPECTRAL RESOLUTION ',NSMAX,' LIN. GRID' +! CALL ABOR1('TRANSFORM_TEST:UNSUPPORTED SPECTRAL RESOLUTION - LIN. GRID') + ENDIF +ELSE + WRITE(NERR,*)'WRONG NLIN=',NLIN +! CALL ABOR1('TRANSFORM_TEST:WRONG NLIN') +ENDIF + +END SUBROUTINE CHECK_NDGL + +! ------------------------------------------------------------------ + +SUBROUTINE SORT(A, N) + IMPLICIT NONE + INTEGER(KIND=JPIM) :: N, I, J + REAL(KIND=JPRD) :: A(N), X + + DO I = 2, N + X = A(I) + J = I - 1 + DO WHILE (J >= 1) + IF (A(J) <= X) EXIT + A(J + 1) = A(J) + J = J - 1 + END DO + A(J + 1) = X + END DO +END SUBROUTINE + +! ------------------------------------------------------------------ + +SUBROUTINE DUMP_GRIDPOINT_FIELD_2D(JSTEP, MYPROC, FLD, FLDCHAR, NOUTDUMP) + +! Dump a 2D field to a binary file. + +INTEGER(KIND=JPIM), INTENT(IN) :: JSTEP ! Time step, used for naming file +INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC ! MPI rank, used for naming file +REAL(KIND=JPRB) , INTENT(IN) :: FLD(:,:) ! 2D field +CHARACTER , INTENT(IN) :: FLDCHAR ! Single character field identifier +INTEGER(KIND=JPIM), INTENT(IN) :: NOUTDUMP ! Unit number for output file + +CHARACTER(LEN=14) :: FILENAME = "X.XXX.XXXX.dat" + +REAL(KIND=JPRB), ALLOCATABLE :: FLD_R(:,:) + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +ALLOCATE(FLD_R(SIZE(FLD,1), SIZE(FLD,2))) +OPEN(NOUTDUMP, FILE='./ref/' // FILENAME, FORM="UNFORMATTED") +READ(NOUTDUMP) FLD_R +CLOSE(NOUTDUMP) + +WRITE(400+MYPROC, *), FILENAME, MAXVAL(ABS(FLD_R-FLD)) + +OPEN(NOUTDUMP, FILE=FILENAME, FORM="UNFORMATTED") +WRITE(NOUTDUMP) FLD +CLOSE(NOUTDUMP) + +END SUBROUTINE DUMP_GRIDPOINT_FIELD_2D +SUBROUTINE DUMP_GRIDPOINT_FIELD_3D(JSTEP, MYPROC, FLD, FLDCHAR, NOUTDUMP) + +! Dump a 3D field to a binary file. + +INTEGER(KIND=JPIM), INTENT(IN) :: JSTEP ! Time step, used for naming file +INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC ! MPI rank, used for naming file +REAL(KIND=JPRB) , INTENT(IN) :: FLD(:,:,:) ! 3D field +CHARACTER , INTENT(IN) :: FLDCHAR ! Single character field identifier +INTEGER(KIND=JPIM), INTENT(IN) :: NOUTDUMP ! Unit number for output file + +CHARACTER(LEN=14) :: FILENAME = "X.XXX.XXXX.dat" +REAL(KIND=JPRB), ALLOCATABLE :: FLD_R(:,:,:) + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +ALLOCATE(FLD_R(SIZE(FLD,1), SIZE(FLD,2), SIZE(FLD,3))) +OPEN(NOUTDUMP, FILE='./ref/' // FILENAME, FORM="UNFORMATTED") +READ(NOUTDUMP) FLD_R +CLOSE(NOUTDUMP) + +WRITE(400+MYPROC, *), FILENAME, MAXVAL(ABS(FLD_R-FLD)) + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +OPEN(NOUTDUMP, FILE=FILENAME, FORM="UNFORMATTED") +WRITE(NOUTDUMP) FLD +CLOSE(NOUTDUMP) + +END SUBROUTINE DUMP_GRIDPOINT_FIELD_3D +SUBROUTINE DUMP_GRIDPOINT_FIELD_4D(JSTEP, MYPROC, FLD, FLDCHAR, NOUTDUMP) + +! Dump a 4D field to a binary file. + +INTEGER(KIND=JPIM), INTENT(IN) :: JSTEP ! Time step, used for naming file +INTEGER(KIND=JPIM), INTENT(IN) :: MYPROC ! MPI rank, used for naming file +REAL(KIND=JPRB) , INTENT(IN) :: FLD(:,:,:,:) ! 4D field +CHARACTER , INTENT(IN) :: FLDCHAR ! Single character field identifier +INTEGER(KIND=JPIM), INTENT(IN) :: NOUTDUMP ! Unit number for output file + +CHARACTER(LEN=14) :: FILENAME = "X.XXX.XXXX.dat" + +REAL(KIND=JPRB), ALLOCATABLE :: FLD_R(:,:,:,:) + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +ALLOCATE(FLD_R(SIZE(FLD,1), SIZE(FLD,2),SIZE(FLD,3),SIZE(FLD,4))) +OPEN(NOUTDUMP, FILE='./ref/' // FILENAME, FORM="UNFORMATTED") +READ(NOUTDUMP) FLD_R +CLOSE(NOUTDUMP) + +WRITE(400+MYPROC, *), FILENAME, MAXVAL(ABS(FLD_R-FLD)) + +WRITE(FILENAME(1:1),'(A1)') FLDCHAR +WRITE(FILENAME(3:5),'(I3.3)') JSTEP +WRITE(FILENAME(7:10),'(I4.4)') MYPROC + +OPEN(NOUTDUMP, FILE=FILENAME, FORM="UNFORMATTED") +WRITE(NOUTDUMP) FLD +CLOSE(NOUTDUMP) + +END SUBROUTINE DUMP_GRIDPOINT_FIELD_4D + +END PROGRAM TRANSFORM_TEST diff --git a/src/trans/gpu/CMakeLists.txt b/src/trans/gpu/CMakeLists.txt index 55cc4a943..bdd3c4f85 100644 --- a/src/trans/gpu/CMakeLists.txt +++ b/src/trans/gpu/CMakeLists.txt @@ -1,4 +1,5 @@ # (C) Copyright 2020- ECMWF. +# (C) Copyright 2022- NVIDIA. # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -25,59 +26,16 @@ endif() set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) -set( FFTW_dp FFTW::fftw3 ) -set( FFTW_sp FFTW::fftw3f ) set( IFS_ACC_Fortran_LIBRARIES OpenACC::OpenACC_Fortran PARENT_SCOPE) foreach( prec sp dp ) if( HAVE_${prec} ) - ecbuild_add_library( - TARGET trans_gpu_${prec} - LINKER_LANGUAGE Fortran - SOURCES ${trans_src} - algor/external/fourier/destroy_plan_fftc.cu - algor/external/fourier/create_plan_fftc.cu - algor/external/fourier/storage_fftc.cu - algor/external/fourier/execute_plan_fftc.cu - PUBLIC_INCLUDES $ - $ - $ - $ - $ - PRIVATE_INCLUDES ${MPI_Fortran_INCLUDE_PATH} - PUBLIC_LIBS parkind_${prec} - fiat - PRIVATE_LIBS ${LAPACK_LIBRARIES} - ) - ecbuild_add_library( - TARGET trans_gpu_static_${prec} - LINKER_LANGUAGE Fortran - SOURCES ${trans_src} - algor/external/fourier/destroy_plan_fftc.cu - algor/external/fourier/create_plan_fftc.cu - algor/external/fourier/storage_fftc.cu - algor/external/fourier/execute_plan_fftc.cu - TYPE STATIC - PUBLIC_INCLUDES $ - $ - $ - $ - $ - PRIVATE_INCLUDES ${MPI_Fortran_INCLUDE_PATH} - PUBLIC_LIBS parkind_${prec} - fiat - PRIVATE_LIBS ${LAPACK_LIBRARIES} - ) ecbuild_add_library( TARGET trans_gpu_static_CA_${prec} LINKER_LANGUAGE Fortran SOURCES ${trans_src} - algor/external/fourier/destroy_plan_fftc.cu - algor/external/fourier/create_plan_fftc.cu - algor/external/fourier/storage_fftc.cu - algor/external/fourier/execute_plan_fftc.cu TYPE STATIC PUBLIC_INCLUDES $ $ @@ -90,70 +48,38 @@ foreach( prec sp dp ) PRIVATE_LIBS ${LAPACK_LIBRARIES} ) - ectrans_target_fortran_module_directory( - TARGET trans_gpu_${prec} - MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/module/trans_gpu_${prec} - INSTALL_DIRECTORY module/trans_gpu_${prec} - ) - ectrans_target_fortran_module_directory( - TARGET trans_gpu_static_${prec} - MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/module/trans_gpu_static_${prec} - INSTALL_DIRECTORY module/trans_gpu_static_${prec} - ) ectrans_target_fortran_module_directory( TARGET trans_gpu_static_CA_${prec} MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/module/trans_gpu_static_CA_${prec} INSTALL_DIRECTORY module/trans_gpu_static_CA_${prec} ) - if( HAVE_FFTW ) - target_link_libraries( trans_gpu_${prec} PRIVATE ${FFTW_LIBRARIES} ) - target_link_libraries( trans_gpu_static_${prec} PRIVATE ${FFTW_LIBRARIES} ) - target_link_libraries( trans_gpu_static_CA_${prec} PRIVATE ${FFTW_LIBRARIES} ) - target_include_directories( trans_gpu_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) - target_include_directories( trans_gpu_static_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) - target_include_directories( trans_gpu_static_CA_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) - target_compile_definitions( trans_gpu_${prec} PRIVATE WITH_FFTW ) - endif() - if( HAVE_OMP ) - target_link_libraries( trans_gpu_${prec} PRIVATE OpenMP::OpenMP_Fortran ) - target_link_libraries( trans_gpu_static_${prec} PRIVATE OpenMP::OpenMP_Fortran ) target_link_libraries( trans_gpu_static_CA_${prec} PRIVATE OpenMP::OpenMP_Fortran ) endif() - target_link_libraries( trans_gpu_${prec} PRIVATE OpenACC::OpenACC_Fortran ) - set_property( TARGET trans_gpu_${prec} PROPERTY CUDA_ARCHITECTURES 70 ) - target_compile_options( trans_gpu_${prec} PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc> ) - target_compile_options( trans_gpu_static_${prec} PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc> ) target_compile_options( trans_gpu_static_CA_${prec} PRIVATE $<$:-g -acc -Minfo=acc -gpu=cc70,lineinfo,deepcopy,fastmath,nordc> ) - - target_link_libraries( trans_gpu_static_${prec} PRIVATE OpenACC::OpenACC_Fortran ) - set_property( TARGET trans_gpu_static_${prec} PROPERTY CUDA_ARCHITECTURES 70 ) - target_link_libraries( trans_gpu_static_CA_${prec} PRIVATE OpenACC::OpenACC_Fortran ) set_property( TARGET trans_gpu_static_CA_${prec} PROPERTY CUDA_ARCHITECTURES 70 ) if( prec STREQUAL sp ) - target_compile_definitions( trans_gpu_${prec} PUBLIC TRANS_SINGLE PARKINDTRANS_SINGLE ) - target_compile_definitions( trans_gpu_static_${prec} PUBLIC TRANS_SINGLE PARKINDTRANS_SINGLE ) - target_compile_definitions( trans_gpu_static_CA_${prec} PUBLIC TRANS_SINGLE PARKINDTRANS_SINGLE ) + target_compile_definitions( trans_gpu_static_CA_${prec} PUBLIC TRANS_SINGLE PARKINDTRANS_SINGLE ) endif() - target_compile_definitions( trans_gpu_static_CA_${prec} PUBLIC USE_CUDA_AWARE_MPI_FT ) - endif() endforeach() +ecbuild_find_package( NAME NvidiaCutlass REQUIRED) + ## precision-independent GPU library with CUDA kernels ecbuild_add_library( TARGET gpu TYPE STATIC SOURCES - algor/module/cublasSgemmBatched.cu - algor/module/cublasDgemmBatched.cu -## algor/module/cublasSTCgemmBatched.cu - algor/module/IPC_Alltoall.cu + algor/external/fourier/fft_wrapper.cu + algor/external/gemm/gemm_wrapper.cu PRIVATE_INCLUDES ${MPI_C_INCLUDE_PATH} + PRIVATE_LIBS nvidia::cutlass::cutlass ) +target_compile_features(gpu PRIVATE cxx_std_17) ## CUDA architecture set_property( TARGET gpu PROPERTY CUDA_ARCHITECTURES 70 ) @@ -161,7 +87,7 @@ set_property( TARGET gpu PROPERTY CUDA_ARCHITECTURES 70 ) ## Install trans interface -file( GLOB trans_interface interface/* ) +file( GLOB trans_interface include/ectrans/* ) install( FILES ${trans_interface} DESTINATION include/ectrans diff --git a/src/trans/gpu/algor/external/fourier/create_plan_fftc.cu b/src/trans/gpu/algor/external/fourier/create_plan_fftc.cu deleted file mode 100644 index b45e329de..000000000 --- a/src/trans/gpu/algor/external/fourier/create_plan_fftc.cu +++ /dev/null @@ -1,167 +0,0 @@ -#define cufftSafeCall(err) __cufftSafeCall(err, __FILE__, __LINE__) -#include "cufft.h" -#include "stdio.h" - static const char *_cudaGetErrorEnum(cufftResult error) - { - switch (error) - { - case CUFFT_SUCCESS: - return "CUFFT_SUCCESS"; - - case CUFFT_INVALID_PLAN: - return "CUFFT_INVALID_PLAN"; - - case CUFFT_ALLOC_FAILED: - return "CUFFT_ALLOC_FAILED"; - - case CUFFT_INVALID_TYPE: - return "CUFFT_INVALID_TYPE"; - - case CUFFT_INVALID_VALUE: - return "CUFFT_INVALID_VALUE"; - - case CUFFT_INTERNAL_ERROR: - return "CUFFT_INTERNAL_ERROR"; - - case CUFFT_EXEC_FAILED: - return "CUFFT_EXEC_FAILED"; - - case CUFFT_SETUP_FAILED: - return "CUFFT_SETUP_FAILED"; - - case CUFFT_INVALID_SIZE: - return "CUFFT_INVALID_SIZE"; - - case CUFFT_UNALIGNED_DATA: - return "CUFFT_UNALIGNED_DATA"; - } - - return ""; - } - - inline void __cufftSafeCall(cufftResult err, const char *file, const int line) - { - if( CUFFT_SUCCESS != err) { - fprintf(stderr, "CUFFT error at 1\n"); - fprintf(stderr, "CUFFT error in file '%s'\n",__FILE__); - fprintf(stderr, "CUFFT error at 2\n"); - /*fprintf(stderr, "CUFFT error line '%s'\n",__LINE__);*/ - fprintf(stderr, "CUFFT error at 3\n"); - /*fprintf(stderr, "CUFFT error in file '%s', line %d\n %s\nerror %d: %s\nterminating!\n",__FILE__, __LINE__,err, \ - _cudaGetErrorEnum(err)); \*/ - fprintf(stderr, "CUFFT error %d: %s\nterminating!\n",err,_cudaGetErrorEnum(err)); \ - cudaDeviceReset(); return; \ - } - } - - -static int allocatedWorkspace=0; -static void* planWorkspace; -static int planWorkspaceSize=100*1024*1024; //100MB - -extern "C" -void -create_plan_fftc_(cufftHandle *PLANp, int *ISIGNp, int *Np, int *LOTp) -{ -int ISIGN = *ISIGNp; -int N = *Np; -int LOT = *LOTp; - -cufftHandle plan; - -if (cudaDeviceSynchronize() != cudaSuccess){ - fprintf(stderr, "Cuda error: Failed to synchronize\n"); - return; -} - - -// //create a single re-usable workspace -// if(!allocatedWorkspace){ -// allocatedWorkspace=1; -// //allocate plan workspace -// cudaMalloc(&planWorkspace,planWorkspaceSize); -// } -// -// //disable auto allocation so we can re-use a single workspace (created above) -// cufftSetAutoAllocation(plan, false); - -int embed[1]; -int stride; -int dist; - -#ifdef TRANS_SINGLE -cufftType cufft_1 = CUFFT_R2C; -cufftType cufft_2 = CUFFT_C2R; -#else -cufftType cufft_1 = CUFFT_D2Z; -cufftType cufft_2 = CUFFT_Z2D; -#endif - -embed[0] = 1; -stride = LOT; -dist = 1; - -cufftSafeCall(cufftCreate(&plan)); - -//printf("CreatePlan cuFFT\n","N=",N); -//printf("%s %d \n","plan=",plan); -//printf("%s %d \n","LOT=",LOT); -//printf("%s %d \n","ISIGN=",ISIGN); -//printf("%s %d \n","Np=",*Np); - -if( ISIGN== -1 ){ - cufftSafeCall(cufftPlanMany(&plan, 1, &N, - embed, stride, dist, - embed, stride, dist, - cufft_1, LOT)); - //cufftSafeCall(cufftPlan1d(&plan, N, CUFFT_D2Z, LOT)); -} -else if( ISIGN== 1){ - cufftSafeCall(cufftPlanMany(&plan, 1, &N, - embed, stride, dist, - embed, stride, dist, - cufft_2, LOT)); - //cufftSafeCall(cufftPlan1d(&plan, N, CUFFT_Z2D, LOT)); -} -else { - abort(); -} - -// // use our reusaable work area for the plan -// cufftSetWorkArea(plan,planWorkspace); - -/* -if( ISIGN== -1 ){ - cufftSafeCall(cufftPlan1d(&plan, N, CUFFT_D2Z, LOT)); -} -else if( ISIGN== 1){ - cufftSafeCall(cufftPlan1d(&plan, N, CUFFT_Z2D, LOT)); -} -else { - abort(); -} -*/ - -if (cudaDeviceSynchronize() != cudaSuccess){ - fprintf(stderr, "Cuda error: Failed to synchronize\n"); - return; -} - -*PLANp=plan; - -// // get size used by this plan -// size_t workSize; -// cufftGetSize(plan,&workSize); -// -// // exit if we don't have enough space for the work area in the re-usable workspace -// if(workSize > planWorkspaceSize){ -// printf("create_plan_fftc: plan workspace size not large enough - exiting\n"); -// exit(1); -// } - - -return; - - -} - diff --git a/src/trans/gpu/algor/external/fourier/destroy_plan_fftc.cu b/src/trans/gpu/algor/external/fourier/destroy_plan_fftc.cu deleted file mode 100644 index d0dd94201..000000000 --- a/src/trans/gpu/algor/external/fourier/destroy_plan_fftc.cu +++ /dev/null @@ -1,77 +0,0 @@ -#define cufftSafeCall(err) __cufftSafeCall(err, __FILE__, __LINE__) -#include "cufft.h" -#include "stdio.h" - static const char *_cudaGetErrorEnum(cufftResult error) - { - switch (error) - { - case CUFFT_SUCCESS: - return "CUFFT_SUCCESS"; - - case CUFFT_INVALID_PLAN: - return "CUFFT_INVALID_PLAN"; - - case CUFFT_ALLOC_FAILED: - return "CUFFT_ALLOC_FAILED"; - - case CUFFT_INVALID_TYPE: - return "CUFFT_INVALID_TYPE"; - - case CUFFT_INVALID_VALUE: - return "CUFFT_INVALID_VALUE"; - - case CUFFT_INTERNAL_ERROR: - return "CUFFT_INTERNAL_ERROR"; - - case CUFFT_EXEC_FAILED: - return "CUFFT_EXEC_FAILED"; - - case CUFFT_SETUP_FAILED: - return "CUFFT_SETUP_FAILED"; - - case CUFFT_INVALID_SIZE: - return "CUFFT_INVALID_SIZE"; - - case CUFFT_UNALIGNED_DATA: - return "CUFFT_UNALIGNED_DATA"; - } - - return ""; - } - - inline void __cufftSafeCall(cufftResult err, const char *file, const int line) - { - if( CUFFT_SUCCESS != err) { - fprintf(stderr, "CUFFT error at 1\n"); - fprintf(stderr, "CUFFT error in file '%s'\n",__FILE__); - fprintf(stderr, "CUFFT error at 2\n"); - /*fprintf(stderr, "CUFFT error line '%s'\n",__LINE__);*/ - fprintf(stderr, "CUFFT error at 3\n"); - /*fprintf(stderr, "CUFFT error in file '%s', line %d\n %s\nerror %d: %s\nterminating!\n",__FILE__, __LINE__,err, \ - _cudaGetErrorEnum(err)); \*/ - fprintf(stderr, "CUFFT error %d: %s\nterminating!\n",err,_cudaGetErrorEnum(err)); \ - cudaDeviceReset(); return; \ - } - } - -extern "C" -void -destroy_plan_fftc_(cufftHandle *PLANp) -{ -cufftHandle plan = *PLANp; - -if (cudaDeviceSynchronize() != cudaSuccess){ - fprintf(stderr, "Cuda error: Failed to synchronize\n"); - return; -} - -cufftSafeCall(cufftDestroy(plan)); - -if (cudaDeviceSynchronize() != cudaSuccess){ - fprintf(stderr, "Cuda error: Failed to synchronize\n"); - return; -} - - -} - diff --git a/src/trans/gpu/algor/external/fourier/execute_plan_fftc.cu b/src/trans/gpu/algor/external/fourier/execute_plan_fftc.cu deleted file mode 100644 index 51a069705..000000000 --- a/src/trans/gpu/algor/external/fourier/execute_plan_fftc.cu +++ /dev/null @@ -1,100 +0,0 @@ -#define cufftSafeCall(err) __cufftSafeCall(err, __FILE__, __LINE__) -#include "cufft.h" -#include "stdio.h" - static const char *_cudaGetErrorEnum(cufftResult error) - { - switch (error) - { - case CUFFT_SUCCESS: - return "CUFFT_SUCCESS"; - - case CUFFT_INVALID_PLAN: - return "CUFFT_INVALID_PLAN"; - - case CUFFT_ALLOC_FAILED: - return "CUFFT_ALLOC_FAILED"; - - case CUFFT_INVALID_TYPE: - return "CUFFT_INVALID_TYPE"; - - case CUFFT_INVALID_VALUE: - return "CUFFT_INVALID_VALUE"; - - case CUFFT_INTERNAL_ERROR: - return "CUFFT_INTERNAL_ERROR"; - - case CUFFT_EXEC_FAILED: - return "CUFFT_EXEC_FAILED"; - - case CUFFT_SETUP_FAILED: - return "CUFFT_SETUP_FAILED"; - - case CUFFT_INVALID_SIZE: - return "CUFFT_INVALID_SIZE"; - - case CUFFT_UNALIGNED_DATA: - return "CUFFT_UNALIGNED_DATA"; - } - - return ""; - } - - inline void __cufftSafeCall(cufftResult err, const char *file, const int line) - { - if( CUFFT_SUCCESS != err) { - fprintf(stderr, "CUFFT error at 1\n"); - fprintf(stderr, "CUFFT error in file '%s'\n",__FILE__); - fprintf(stderr, "CUFFT error at 2\n"); - /*fprintf(stderr, "CUFFT error line '%s'\n",__LINE__);*/ - fprintf(stderr, "CUFFT error at 3\n"); - /*fprintf(stderr, "CUFFT error in file '%s', line %d\n %s\nerror %d: %s\nterminating!\n",__FILE__, __LINE__,err, \ - _cudaGetErrorEnum(err)); \*/ - fprintf(stderr, "CUFFT error %d: %s\nterminating!\n",err,_cudaGetErrorEnum(err)); \ - cudaDeviceReset(); return; \ - } - } - -extern "C" -void -#ifdef TRANS_SINGLE -execute_plan_fftc_(cufftHandle *PLANp, int *ISIGNp, cufftComplex *data_in, cufftComplex *data_out) -#else -execute_plan_fftc_(cufftHandle *PLANp, int *ISIGNp, cufftDoubleComplex *data_in, cufftDoubleComplex *data_out) -#endif -{ -cufftHandle plan = *PLANp; -int ISIGN = *ISIGNp; - -/*if (cudaDeviceSynchronize() != cudaSuccess){ - fprintf(stderr, "Cuda error: Failed to synchronize\n"); - return; -}*/ - -if( ISIGN== -1 ){ - #ifdef TRANS_SINGLE - cufftSafeCall(cufftExecR2C(plan, (cufftReal*)data_in, data_out)); - #else - cufftSafeCall(cufftExecD2Z(plan, (cufftDoubleReal*)data_in, data_out)); - #endif -} -else if( ISIGN== 1){ - #ifdef TRANS_SINGLE - cufftSafeCall(cufftExecC2R(plan, data_in, (cufftReal*)data_out)); - #else - cufftSafeCall(cufftExecZ2D(plan, data_in, (cufftDoubleReal*)data_out)); - #endif -} -else { - abort(); -} - -// cudaDeviceSynchronize(); - -//if (cudaDeviceSynchronize() != cudaSuccess){ -// fprintf(stderr, "Cuda error: Failed to synchronize\n"); -// return; -//} - - -} - diff --git a/src/trans/gpu/algor/external/fourier/fft_wrapper.cu b/src/trans/gpu/algor/external/fourier/fft_wrapper.cu new file mode 100644 index 000000000..d4f3d7f5d --- /dev/null +++ b/src/trans/gpu/algor/external/fourier/fft_wrapper.cu @@ -0,0 +1,203 @@ +// (C) Copyright 2022- NVIDIA. +// +// This software is licensed under the terms of the Apache Licence Version 2.0 +// which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +// In applying this licence, ECMWF does not 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 "cufft.h" +#include "stdio.h" +#include +#include +#include + +static const char *_cudaGetErrorEnum(cufftResult error) { + switch (error) { + case CUFFT_SUCCESS: + return "CUFFT_SUCCESS"; + + case CUFFT_INVALID_PLAN: + return "CUFFT_INVALID_PLAN"; + + case CUFFT_ALLOC_FAILED: + return "CUFFT_ALLOC_FAILED"; + + case CUFFT_INVALID_TYPE: + return "CUFFT_INVALID_TYPE"; + + case CUFFT_INVALID_VALUE: + return "CUFFT_INVALID_VALUE"; + + case CUFFT_INTERNAL_ERROR: + return "CUFFT_INTERNAL_ERROR"; + + case CUFFT_EXEC_FAILED: + return "CUFFT_EXEC_FAILED"; + + case CUFFT_SETUP_FAILED: + return "CUFFT_SETUP_FAILED"; + + case CUFFT_INVALID_SIZE: + return "CUFFT_INVALID_SIZE"; + + case CUFFT_UNALIGNED_DATA: + return "CUFFT_UNALIGNED_DATA"; + } + + return ""; +} +#define CUDA_CHECK(e) \ + { \ + cudaError_t err = (e); \ + if (err != cudaSuccess) { \ + fprintf(stderr, "CUDA error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ + #e, cudaGetErrorString(err)); \ + exit(EXIT_FAILURE); \ + } \ + } + +#define CUFFT_CHECK(e) \ + { \ + cufftResult_t err = (e); \ + if (err != CUFFT_SUCCESS) { \ + fprintf(stderr, "CUFFT error: %s, line %d, %s: %s\n", __FILE__, \ + __LINE__, #e, _cudaGetErrorEnum(err)); \ + exit(EXIT_FAILURE); \ + } \ + } + +extern void *planWorkspace; + +namespace { +struct Double { + using real = double; + using cmplx = cufftDoubleComplex; +}; +struct Float { + using real = float; + using cmplx = cufftComplex; +}; +} // namespace +template +void execute_fft(typename Type::real *data_real, + typename Type::cmplx *data_complex, int kfield, int *loens, + int *offsets, int nfft) { + constexpr bool is_forward = Direction == CUFFT_R2C || Direction == CUFFT_D2Z; + using real = typename Type::real; + using cmplx = typename Type::cmplx; + + /* static std::unordered_map allocationCache; // nloens -> ptr */ + static std::unordered_map> + fftPlansCache; // kfield -> handles + static std::unordered_map + graphCache; // kfield -> graphs + + // if the pointers are changed, we need to update the graph + static std::unordered_map> + ptrCache; // kfield -> ptrs + + auto ptrs = ptrCache.find(kfield); + if (ptrs != ptrCache.end() && (ptrs->second.first != data_real || + ptrs->second.second != data_complex)) { + // the plan is cached, but the pointers are not correct. we remove and + // delete the graph, but we keep the FFT plans, if this happens more often, + // we should cache this... + std::cout << "WARNING FFT: POINTER CHANGE --> THIS MIGHT BE SLOW" << std::endl; + CUDA_CHECK(cudaGraphExecDestroy(graphCache[kfield])); + graphCache.erase(kfield); + ptrCache.erase(kfield); + } + + auto graph = graphCache.find(kfield); + if (graph == graphCache.end()) { + // this graph does not exist yet + + auto fftPlans = fftPlansCache.find(kfield); + if (fftPlans == fftPlansCache.end()) { + // the fft plans do not exist yet + std::vector newPlans; + newPlans.resize(nfft); + for (int i = 0; i < nfft; ++i) { + int nloen = loens[i]; + + cufftHandle plan; + CUFFT_CHECK(cufftCreate(&plan)); + int dist = offsets[i + 1] - offsets[i]; + int embed[] = {1}; + CUFFT_CHECK(cufftPlanMany( + &plan, 1, &nloen, embed, 1, is_forward ? dist : dist / 2, embed, 1, + is_forward ? dist / 2 : dist, Direction, kfield)); + newPlans[i] = plan; + } + fftPlansCache.insert({kfield, newPlans}); + } + fftPlans = fftPlansCache.find(kfield); + + // create a temporary stream + cudaStream_t stream; + CUDA_CHECK(cudaStreamCreate(&stream)); + + for (auto &plan : fftPlans->second) // set the streams + CUFFT_CHECK(cufftSetStream(plan, stream)); + + // now create the cuda graph + cudaGraph_t new_graph; + cudaGraphCreate(&new_graph, 0); + for (int i = 0; i < nfft; ++i) { + int offset = offsets[i]; + real *data_real_l = &data_real[kfield * offset]; + cmplx *data_complex_l = &data_complex[kfield * offset / 2]; + CUDA_CHECK(cudaStreamBeginCapture(stream, cudaStreamCaptureModeGlobal)); + if constexpr (Direction == CUFFT_R2C) + CUFFT_CHECK( + cufftExecR2C(fftPlans->second[i], data_real_l, data_complex_l)) + else if constexpr (Direction == CUFFT_C2R) + CUFFT_CHECK( + cufftExecC2R(fftPlans->second[i], data_complex_l, data_real_l)) + else if constexpr (Direction == CUFFT_D2Z) + CUFFT_CHECK( + cufftExecD2Z(fftPlans->second[i], data_real_l, data_complex_l)) + else if constexpr (Direction == CUFFT_Z2D) + CUFFT_CHECK( + cufftExecZ2D(fftPlans->second[i], data_complex_l, data_real_l)); + cudaGraph_t my_graph; + CUDA_CHECK(cudaStreamEndCapture(stream, &my_graph)); + cudaGraphNode_t my_node; + CUDA_CHECK(cudaGraphAddChildGraphNode(&my_node, new_graph, nullptr, 0, + my_graph)); + } + cudaGraphExec_t instance; + CUDA_CHECK(cudaGraphInstantiate(&instance, new_graph, NULL, NULL, 0)); + CUDA_CHECK(cudaStreamDestroy(stream)); + CUDA_CHECK(cudaGraphDestroy(new_graph)); + + graphCache.insert({kfield, instance}); + ptrCache.insert({kfield, std::make_pair(data_real, data_complex)}); + } + + CUDA_CHECK(cudaGraphLaunch(graphCache.at(kfield), 0)); + CUDA_CHECK(cudaDeviceSynchronize()); +} +extern "C" { +void execute_dir_fft_float(float *data_real, cufftComplex *data_complex, + int kfield, int *loens, int *offsets, int nfft) { + execute_fft(data_real, data_complex, kfield, loens, offsets, + nfft); +} +void execute_inv_fft_float(cufftComplex *data_complex, float *data_real, + int kfield, int *loens, int *offsets, int nfft) { + execute_fft(data_real, data_complex, kfield, loens, offsets, + nfft); +} +void execute_dir_fft_double(double *data_real, cufftDoubleComplex *data_complex, + int kfield, int *loens, int *offsets, int nfft) { + execute_fft(data_real, data_complex, kfield, loens, + offsets, nfft); +} +void execute_inv_fft_double(cufftDoubleComplex *data_complex, double *data_real, + int kfield, int *loens, int *offsets, int nfft) { + execute_fft(data_real, data_complex, kfield, loens, + offsets, nfft); +} +} diff --git a/src/trans/gpu/algor/external/fourier/storage_fftc.cu b/src/trans/gpu/algor/external/fourier/storage_fftc.cu deleted file mode 100644 index 7badd5fab..000000000 --- a/src/trans/gpu/algor/external/fourier/storage_fftc.cu +++ /dev/null @@ -1,28 +0,0 @@ -#include "cufft.h" -#include "stdio.h" -extern "C" -cufftDoubleComplex *create_storage_(int *Np) -{ - int N = *Np; - cufftDoubleComplex *data; - /*cudaMalloc((void**)&data,sizeof(cufftDoubleComplex)*N); - if (cudaGetLastError() != cudaSuccess){ - fprintf(stderr, "Cuda error: Failed to allocate\n"); - return 0; - } - return data;*/ - printf("%s %d \n","sizeof(cufftDoubleComplex)=",sizeof(cufftDoubleComplex)); - printf("%s %d \n","N=",N); - if (cudaMalloc(&data, sizeof(cufftDoubleComplex)*N) == cudaSuccess){ - printf("%s %X \n","data ",data); - return data; - } - fprintf(stderr, "Cuda error: Failed to allocate\n"); - return 0; -} - -extern "C" -void destroy_storage_(int *ptr) -{ - cudaFree(ptr); -} diff --git a/src/trans/gpu/algor/external/gemm/gemm_wrapper.cu b/src/trans/gpu/algor/external/gemm/gemm_wrapper.cu new file mode 100644 index 000000000..70ec2e47a --- /dev/null +++ b/src/trans/gpu/algor/external/gemm/gemm_wrapper.cu @@ -0,0 +1,426 @@ +// (C) Copyright 2022- NVIDIA. +// +// This software is licensed under the terms of the Apache Licence Version 2.0 +// which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +// In applying this licence, ECMWF does not 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 "cublas_v2.h" +#include "cutlass/gemm/device/gemm.h" + +constexpr bool use_cutlass = true; + +#define CUDA_CHECK(e) \ + { \ + cudaError_t err = (e); \ + if (err != cudaSuccess) { \ + fprintf(stderr, "CUDA error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ + #e, cudaGetErrorString(err)); \ + exit(EXIT_FAILURE); \ + } \ + } +#define CUBLAS_CHECK(e) \ + { \ + cublasStatus_t err = (e); \ + if (err != CUBLAS_STATUS_SUCCESS) { \ + fprintf(stderr, "CUBLAS error: %s, line %d, %s: %i\n", __FILE__, \ + __LINE__, #e, err); \ + exit(EXIT_FAILURE); \ + } \ + } +#define CUTLASS_CHECK(e) \ + { \ + cutlass::Status err = (e); \ + if (err != cutlass::Status::kSuccess) { \ + fprintf(stderr, "CUTLASS error: %s, line %d, %s: %i\n", __FILE__, \ + __LINE__, #e, (int)err); \ + exit(EXIT_FAILURE); \ + } \ + } + +namespace { +namespace detail { +struct pair_hash { + std::size_t operator()(const std::pair &p) const { + return p.first * 10000 + p.second; + } +}; +} // namespace detail + +// this version is using cuda graphs and caches the graphs +template +void run_group_graph(Gemm &&gemm, int m, int *n, int *k, Real alpha, + const Real *A, int lda, int *offsetsA, const Real *B, + int ldb, int *offsetsB, Real beta, Real *C, int ldc, + int *offsetsC, int batchCount, cudaStream_t stream, + int blas_id = -1) { + // we store at most one graph per "m" (# fields) and "blas id" + static std::unordered_map, cudaGraphExec_t, + detail::pair_hash> + graphCache; + + // we also store A, B, and C and recreate the graph if they change + static std::unordered_map< + std::pair, std::tuple, + detail::pair_hash> + ptrCache; + + auto key = std::make_pair(m, blas_id); + + auto ptrs = ptrCache.find(key); + if (ptrs != ptrCache.end() && + (std::get<0>(ptrs->second) != A || std::get<1>(ptrs->second) != B || + std::get<2>(ptrs->second) != C)) { + // the plan is cached, but the pointers are not correct. we remove and + // delete the graph, but we keep the cublas handles, if this happens more + // often, we should cache this... + std::cout << "WARNING GEMM: POINTER CHANGE - Graph recreation might be slow.\n"; + std::cout << "We have an entry with key {m=" << m << ", blas_id=" << blas_id << "}\n"; + std::cout << "Pointers: " << std::get<0>(ptrs->second) << ", " << std::get<1>(ptrs->second) << ", " << std::get<2>(ptrs->second) << " vs. " + << A << ", " << B << ", " << C << std::endl; + CUDA_CHECK(cudaGraphExecDestroy(graphCache[key])); + graphCache.erase(key); + ptrCache.erase(key); + } + + auto graph = graphCache.find(key); + if (graph == graphCache.end()) { + // this graph does not exist yet + cudaStream_t stream; + CUDA_CHECK(cudaStreamCreate(&stream)); + + cudaGraph_t new_graph; + cudaGraphCreate(&new_graph, 0); + for (int i = 0; i < batchCount; ++i) { + if (m == 0 || n[i] == 0 || k[i] == 0) continue; + + CUDA_CHECK(cudaStreamBeginCapture(stream, cudaStreamCaptureModeGlobal)); + gemm(stream, m, n[i], k[i], alpha, A + offsetsA[i], lda, B + offsetsB[i], + ldb, beta, C + offsetsC[i], ldc); + cudaGraph_t my_graph; + CUDA_CHECK(cudaStreamEndCapture(stream, &my_graph)); + cudaGraphNode_t my_node; + CUDA_CHECK(cudaGraphAddChildGraphNode(&my_node, new_graph, nullptr, 0, + my_graph)); + } + cudaGraphExec_t instance; + CUDA_CHECK(cudaGraphInstantiate(&instance, new_graph, NULL, NULL, 0)); + CUDA_CHECK(cudaStreamDestroy(stream)); + CUDA_CHECK(cudaGraphDestroy(new_graph)); + + graphCache.insert({key, instance}); + ptrCache.insert({key, std::make_tuple(A, B, C)}); + } + + CUDA_CHECK(cudaGraphLaunch(graphCache.at(key), stream)); +} + +// stupid simple gemm calls +template +void run_group(Gemm &&gemm, int m, int *n, int *k, Real alpha, const Real *A, + int lda, int *offsetsA, const Real *B, int ldb, int *offsetsB, + Real beta, Real *C, int ldc, int *offsetsC, int batchCount, + cudaStream_t stream, int = -1) { + for (int i = 0; i < batchCount; ++i) { + if (m == 0 || n[i] == 0 || k[i] == 0) continue; + gemm(stream, m, n[i], k[i], alpha, A + offsetsA[i], lda, B + offsetsB[i], + ldb, beta, C + offsetsC[i], ldc); + } +} + +template +CutlassGemm &get_cutlass_handle() { + static auto handle = std::make_unique(); + return *handle; +} + +namespace detail { + +enum class CutlassType { cutlass_3xtf32, cutlass_fp32 }; + +template +class cutlass_sgemm_grouped; + +template +class cutlass_sgemm_grouped { + // this was verified using Ampere and uses 3XTF32 + static constexpr int AlignmentA = 4; + static constexpr int AlignmentB = 4; + using ThreadblockShape = cutlass::gemm::GemmShape<128, 64, 32>; + using WarpShape = cutlass::gemm::GemmShape<64, 32, 32>; + using InstructionShape = cutlass::gemm::GemmShape<16, 8, 8>; + using OperatorClass = cutlass::arch::OpClassTensorOp; + using MyOp = cutlass::arch::OpMultiplyAddFastF32; + + using Gemm = cutlass::gemm::device::Gemm< + float, + std::conditional_t, // + float, + std::conditional_t, // + float, cutlass::layout::ColumnMajor, // + float, // + OperatorClass, cutlass::arch::Sm80, // + ThreadblockShape, WarpShape, InstructionShape, // + cutlass::epilogue::thread::LinearCombination< // + float, // + 128 / cutlass::sizeof_bits::value, + float, // + float // + >, // + cutlass::gemm::threadblock::GemmIdentityThreadblockSwizzle<>, // + 3, // + AlignmentA, // + AlignmentB, // + true, // + MyOp // + >; + static constexpr int sz_align = 8; + + public: + void operator()(cudaStream_t stream, int m, int n, int k, float alpha, + const float *A, int lda, const float *B, int ldb, float beta, + float *C, int ldc) const { + auto &gemm_op = get_cutlass_handle(); + CUTLASS_CHECK(gemm_op( + {// + {(m + sz_align - 1) / sz_align * sz_align, + (n + sz_align - 1) / sz_align * sz_align, + (k + sz_align - 1) / sz_align * sz_align}, + {const_cast(A), lda}, + {const_cast(B), ldb}, + {C, ldc}, + {C, ldc}, + {alpha, beta}}, + nullptr, stream)); + } +}; +template +class cutlass_sgemm_grouped { + // this was verified using Volta and uses FP32 + static constexpr int AlignmentA = 1; + static constexpr int AlignmentB = 1; + using ThreadblockShape = cutlass::gemm::GemmShape<128, 128, 8>; + using WarpShape = cutlass::gemm::GemmShape<32, 32, 8>; + using InstructionShape = cutlass::gemm::GemmShape<1, 1, 1>; + using OperatorClass = cutlass::arch::OpClassSimt; + using MyOp = cutlass::arch::OpMultiplyAdd; + + using Gemm = cutlass::gemm::device::Gemm< + float, // + std::conditional_t, // + float, // + std::conditional_t, // + float, cutlass::layout::ColumnMajor, // + float, // + OperatorClass, cutlass::arch::Sm70, // + ThreadblockShape, WarpShape, InstructionShape, // + cutlass::epilogue::thread::LinearCombination< // + float, // + 1, // + float, // + float // + >, // + cutlass::gemm::threadblock::GemmIdentityThreadblockSwizzle<>, // + 2, // + AlignmentA, // + AlignmentB, // + true, // + MyOp // + >; + static constexpr int sz_align = 1; + + public: + void operator()(cudaStream_t stream, int m, int n, int k, float alpha, + const float *A, int lda, const float *B, int ldb, float beta, + float *C, int ldc) const { + auto &gemm_op = get_cutlass_handle(); + CUTLASS_CHECK(gemm_op( + {// + {(m + sz_align - 1) / sz_align * sz_align, + (n + sz_align - 1) / sz_align * sz_align, + (k + sz_align - 1) / sz_align * sz_align}, + {const_cast(A), lda}, + {const_cast(B), ldb}, + {C, ldc}, + {C, ldc}, + {alpha, beta}}, + nullptr, stream)); + } +}; + +} // namespace detail +template +void cutlass_sgemm_wrapper_grouped_op(int blas_id, int m, int *n, int *k, + float alpha, const float *A, int lda, + int *offsetsA, const float *B, int ldb, + int *offsetsB, float beta, float *C, + int ldc, int *offsetsC, int batchCount, + cudaStream_t stream) { + using namespace detail; + int device; + CUDA_CHECK(cudaGetDevice(&device)); + int capability_major; + CUDA_CHECK(cudaDeviceGetAttribute(&capability_major, + cudaDevAttrComputeCapabilityMajor, device)); + if (capability_major >= 8) + run_group_graph(cutlass_sgemm_grouped(), + m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, + ldc, offsetsC, batchCount, stream, blas_id); + else + run_group_graph(cutlass_sgemm_grouped(), + m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, + ldc, offsetsC, batchCount, stream, blas_id); +} +void cutlass_sgemm_wrapper_grouped(int blas_id, cublasOperation_t transa, + cublasOperation_t transb, int m, int *n, + int *k, float alpha, const float *A, int lda, + int *offsetsA, const float *B, int ldb, + int *offsetsB, float beta, float *C, int ldc, + int *offsetsC, int batchCount, + cudaStream_t stream) { + if (transa == CUBLAS_OP_N && transb == CUBLAS_OP_N) + cutlass_sgemm_wrapper_grouped_op( + blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, + ldc, offsetsC, batchCount, stream); + else if (transa == CUBLAS_OP_N && transb == CUBLAS_OP_T) + cutlass_sgemm_wrapper_grouped_op( + blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, + ldc, offsetsC, batchCount, stream); + else if (transa == CUBLAS_OP_T && transb == CUBLAS_OP_N) + cutlass_sgemm_wrapper_grouped_op( + blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, + ldc, offsetsC, batchCount, stream); + else if (transa == CUBLAS_OP_T && transb == CUBLAS_OP_T) + cutlass_sgemm_wrapper_grouped_op( + blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, + ldc, offsetsC, batchCount, stream); + else + assert(false); +} + +namespace detail { +cublasHandle_t get_cublas_handle() { + static cublasHandle_t handle; + if (!handle) CUBLAS_CHECK(cublasCreate(&handle)); + return handle; +} +template +struct cublas_gemm_grouped { + public: + cublas_gemm_grouped(cublasOperation_t transa, cublasOperation_t transb) + : transa_(transa), transb_(transb) { + // we need to get the cublas handle here, otherwise this could be created + // during graph capturing + get_cublas_handle(); + }; + void operator()(cudaStream_t stream, int m, int n, int k, Real alpha, + const Real *A, int lda, const Real *B, int ldb, Real beta, + Real *C, int ldc) const { + cublasHandle_t handle = get_cublas_handle(); + CUBLAS_CHECK(cublasSetStream(handle, stream)); + + if constexpr (std::is_same::value) + CUBLAS_CHECK(cublasSgemm(handle, transa_, transb_, m, n, k, &alpha, A, + lda, B, ldb, &beta, C, ldc)); + if constexpr (std::is_same::value) + CUBLAS_CHECK(cublasDgemm(handle, transa_, transb_, m, n, k, &alpha, A, + lda, B, ldb, &beta, C, ldc)); + } + + private: + cublasOperation_t transa_, transb_; +}; +} // namespace detail +void cublas_sgemm_wrapper_grouped(int blas_id, cublasOperation_t transa, + cublasOperation_t transb, int m, int *n, + int *k, float alpha, const float *A, int lda, + int *offsetsA, const float *B, int ldb, + int *offsetsB, float beta, float *C, int ldc, + int *offsetsC, int batchCount, + cudaStream_t stream) { + using namespace detail; + run_group_graph(cublas_gemm_grouped(transa, transb), m, n, k, alpha, A, + lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, + batchCount, stream, blas_id); +} +void cublas_dgemm_wrapper_grouped(int blas_id, cublasOperation_t transa, + cublasOperation_t transb, int m, int *n, + int *k, double alpha, const double *A, + int lda, int *offsetsA, const double *B, + int ldb, int *offsetsB, double beta, + double *C, int ldc, int *offsetsC, + int batchCount, cudaStream_t stream) { + using namespace detail; + run_group(cublas_gemm_grouped(transa, transb), m, n, k, alpha, A, lda, + offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, + stream, blas_id); +} + +} // namespace + +extern "C" { +void cublas_dgemm_wrapper(cublasOperation_t transa, cublasOperation_t transb, + int m, int n, int k, double alpha, const double *A, + int lda, int tda, const double *B, int ldb, int tdb, + double beta, double *C, int ldc, int tdc, + int batchCount, size_t stream) { + cublasHandle_t handle = detail::get_cublas_handle(); + CUBLAS_CHECK(cublasSetStream(handle, *(cudaStream_t *)stream)); + CUBLAS_CHECK(cublasDgemmStridedBatched(handle, transa, transb, m, n, k, + &alpha, A, lda, tda, B, ldb, tdb, + &beta, C, ldc, tdc, batchCount)); +} + +void cublas_sgemm_wrapper(cublasOperation_t transa, cublasOperation_t transb, + int m, int n, int k, float alpha, const float *A, + int lda, int tda, const float *B, int ldb, int tdb, + float beta, float *C, int ldc, int tdc, + int batchCount, size_t stream) { + cublasHandle_t handle = detail::get_cublas_handle(); + CUBLAS_CHECK(cublasSetStream(handle, *(cudaStream_t *)stream)); + CUBLAS_CHECK(cublasSgemmStridedBatched(handle, transa, transb, m, n, k, + &alpha, A, lda, tda, B, ldb, tdb, + &beta, C, ldc, tdc, batchCount)); +} + +void blas_sgemm_wrapper_grouped(int blas_id, cublasOperation_t transa, + cublasOperation_t transb, int m, int *n, int *k, + float alpha, const float *A, int lda, + int *offsetsA, const float *B, int ldb, + int *offsetsB, float beta, float *C, int ldc, + int *offsetsC, int batchCount, size_t stream) { + if (use_cutlass) + cutlass_sgemm_wrapper_grouped( + blas_id, transa, transb, m, n, k, alpha, A, lda, offsetsA, B, ldb, + offsetsB, beta, C, ldc, offsetsC, batchCount, *(cudaStream_t *)stream); + else + cublas_sgemm_wrapper_grouped(blas_id, transa, transb, m, n, k, alpha, A, lda, + offsetsA, B, ldb, offsetsB, beta, C, ldc, + offsetsC, batchCount, *(cudaStream_t *)stream); +} +void blas_dgemm_wrapper_grouped(int blas_id, cublasOperation_t transa, + cublasOperation_t transb, int m, int *n, int *k, + double alpha, const double *A, int lda, + int *offsetsA, const double *B, int ldb, + int *offsetsB, double beta, double *C, int ldc, + int *offsetsC, int batchCount, size_t stream) { + cublas_dgemm_wrapper_grouped(blas_id, transa, transb, m, n, k, alpha, A, lda, offsetsA, + B, ldb, offsetsB, beta, C, ldc, offsetsC, + batchCount, *(cudaStream_t *)stream); +} +} diff --git a/src/trans/gpu/algor/interface/dbfgsl.h b/src/trans/gpu/algor/interface/dbfgsl.h deleted file mode 100644 index 2e52a48db..000000000 --- a/src/trans/gpu/algor/interface/dbfgsl.h +++ /dev/null @@ -1,16 +0,0 @@ -INTERFACE -subroutine dbfgsl (K_N,YD_D,K_M,K_NYS,K_JMIN,K_JMAX,YD_YBAR,YD_SBAR,P_RHO,P_SIZE) -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE CONTROL_VECTORS_MOD -INTEGER(KIND=JPIM),INTENT(IN) :: K_M -INTEGER(KIND=JPIM) :: K_N -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_D -INTEGER(KIND=JPIM),INTENT(IN) :: K_NYS -INTEGER(KIND=JPIM),INTENT(IN) :: K_JMIN -INTEGER(KIND=JPIM),INTENT(IN) :: K_JMAX -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_YBAR(K_M) -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_SBAR(K_M) -REAL(KIND=JPRB) ,INTENT(OUT) :: P_RHO(K_M) -REAL(KIND=JPRB) ,INTENT(IN) :: P_SIZE -end subroutine dbfgsl -END INTERFACE diff --git a/src/trans/gpu/algor/interface/dpseuclid.h b/src/trans/gpu/algor/interface/dpseuclid.h deleted file mode 100644 index cb949fd3c..000000000 --- a/src/trans/gpu/algor/interface/dpseuclid.h +++ /dev/null @@ -1,11 +0,0 @@ -INTERFACE -subroutine dpseuclid (K_N,YD_X,YD_Y,P_SP) -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE PARKIND2 ,ONLY : JPRH -USE CONTROL_VECTORS_MOD -INTEGER(KIND=JPIM) :: K_N -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_X -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_Y -REAL(KIND=JPRH) ,INTENT(OUT) :: P_SP -end subroutine dpseuclid -END INTERFACE diff --git a/src/trans/gpu/algor/interface/dysave.h b/src/trans/gpu/algor/interface/dysave.h deleted file mode 100644 index c7bfaf89c..000000000 --- a/src/trans/gpu/algor/interface/dysave.h +++ /dev/null @@ -1,27 +0,0 @@ -INTERFACE -subroutine dysave (K_N,YD_Y,YD_S,P_YS,K_M,K_NYS,K_JMIN,K_JMAX,YD_YBAR,YD_SBAR,K_SELECT,& - & K_IITER,P_OL,K_JOL,P_EPS,P_SIZE,K_MODE,K_PLEV,K_IO) -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE PARKIND2 ,ONLY : JPRH -USE CONTROL_VECTORS_MOD -INTEGER(KIND=JPIM),INTENT(IN) :: K_M -INTEGER(KIND=JPIM) :: K_N -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_Y -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_S -REAL(KIND=JPRH) ,INTENT(IN) :: P_YS -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_NYS -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMIN -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMAX -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_YBAR(K_M) -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_SBAR(K_M) -INTEGER(KIND=JPIM),INTENT(IN) :: K_SELECT -INTEGER(KIND=JPIM),INTENT(IN) :: K_IITER -REAL(KIND=JPRB) ,INTENT(INOUT) :: P_OL(K_M) -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JOL(K_M) -REAL(KIND=JPRB) ,INTENT(IN) :: P_EPS -REAL(KIND=JPRB) ,INTENT(OUT) :: P_SIZE -INTEGER(KIND=JPIM),INTENT(OUT) :: K_MODE -INTEGER(KIND=JPIM),INTENT(IN) :: K_PLEV -INTEGER(KIND=JPIM),INTENT(IN) :: K_IO -end subroutine dysave -END INTERFACE diff --git a/src/trans/gpu/algor/interface/eigsol.h b/src/trans/gpu/algor/interface/eigsol.h deleted file mode 100644 index a689b8f37..000000000 --- a/src/trans/gpu/algor/interface/eigsol.h +++ /dev/null @@ -1,17 +0,0 @@ -INTERFACE -SUBROUTINE EIGSOL(KFLEVG,KNFLEVG,PA,PFR,PFI,K,PMO,KWO,PWO,KER) -USE PARKIND1 ,ONLY : JPIM ,JPRB - -INTEGER(KIND=JPIM),INTENT(IN) :: KFLEVG -INTEGER(KIND=JPIM),INTENT(IN) :: KNFLEVG -REAL(KIND=JPRB),INTENT(IN) :: PA(*) -REAL(KIND=JPRB),INTENT(OUT) :: PFR(*) -REAL(KIND=JPRB),INTENT(OUT) :: PFI(*) -INTEGER(KIND=JPIM),INTENT(IN) :: K -REAL(KIND=JPRB),INTENT(OUT) :: PMO(*) -INTEGER(KIND=JPIM),INTENT(OUT) :: KWO(*) -REAL(KIND=JPRB),INTENT(OUT) :: PWO(*) -INTEGER(KIND=JPIM),INTENT(OUT) :: KER - -END SUBROUTINE EIGSOL -END INTERFACE diff --git a/src/trans/gpu/algor/interface/intavg.h b/src/trans/gpu/algor/interface/intavg.h deleted file mode 100644 index b038b9c2c..000000000 --- a/src/trans/gpu/algor/interface/intavg.h +++ /dev/null @@ -1,9 +0,0 @@ -INTERFACE - SUBROUTINE INTAVG(PVLEV,PVI,KNIDIM,KNI,KNPROF,KNO,PPO,PVO) - USE PARKIND1 ,ONLY : JPIM ,JPRB - INTEGER(KIND=JPIM), INTENT(in) :: KNIDIM, KNI, KNO, KNPROF - REAL(KIND=JPRB), INTENT(in) :: PVLEV(KNIDIM,KNPROF) - REAL(KIND=JPRB), INTENT(in) :: PPO(KNO),PVI(KNIDIM,KNPROF) - REAL(KIND=JPRB), INTENT(inout) :: PVO(KNO,KNPROF) - END SUBROUTINE INTAVG -END INTERFACE diff --git a/src/trans/gpu/algor/interface/layeravg.h b/src/trans/gpu/algor/interface/layeravg.h deleted file mode 100644 index 5d0453a50..000000000 --- a/src/trans/gpu/algor/interface/layeravg.h +++ /dev/null @@ -1,9 +0,0 @@ -INTERFACE - SUBROUTINE LAYERAVG(LDGRADPS,PX1,PX2,PY2,KN1,KN2,KI,PZ,PZS,PZPS) - USE PARKIND1 ,ONLY : JPIM ,JPRB - LOGICAL, INTENT(in) :: LDGRADPS - INTEGER(KIND=JPIM), INTENT(in) :: KN1,KN2,KI - REAL(KIND=JPRB), INTENT(in) :: PX1(KN1),PX2(KN2),PY2(KN2),PZS(KN2) - REAL(KIND=JPRB), INTENT(inout) :: PZ(KN2),PZPS - END SUBROUTINE LAYERAVG -END INTERFACE diff --git a/src/trans/gpu/algor/interface/minv.h b/src/trans/gpu/algor/interface/minv.h deleted file mode 100644 index 323749e00..000000000 --- a/src/trans/gpu/algor/interface/minv.h +++ /dev/null @@ -1,13 +0,0 @@ -INTERFACE -SUBROUTINE MINV(PAB,KDIMN,KDBA,PZSCRA,PDET1,PTOL,KDIMM,KMODE) -USE PARKIND1, ONLY : JPIM, JPRB -INTEGER(KIND=JPIM), INTENT(IN) :: KDIMN -INTEGER(KIND=JPIM), INTENT(IN) :: KDBA -INTEGER(KIND=JPIM), INTENT(IN) :: KDIMM -INTEGER(KIND=JPIM), INTENT(IN) :: KMODE -REAL(KIND=JPRB), INTENT(IN) :: PTOL -REAL(KIND=JPRB), INTENT(OUT) :: PDET1 -REAL(KIND=JPRB), INTENT(INOUT) :: PAB(KDBA,KDIMN+KDIMM) -REAL(KIND=JPRB), INTENT(INOUT) :: PZSCRA(2*KDIMN) -END SUBROUTINE MINV -END INTERFACE diff --git a/src/trans/gpu/algor/interface/minv_8.h b/src/trans/gpu/algor/interface/minv_8.h deleted file mode 100644 index 97a81742f..000000000 --- a/src/trans/gpu/algor/interface/minv_8.h +++ /dev/null @@ -1,13 +0,0 @@ -INTERFACE -SUBROUTINE MINV_8(PAB,KDIMN,KDBA,PZSCRA,PDET1,PTOL,KDIMM,KMODE) -USE PARKIND1, ONLY : JPIM, JPRD -INTEGER(KIND=JPIM), INTENT(IN) :: KDIMN -INTEGER(KIND=JPIM), INTENT(IN) :: KDBA -INTEGER(KIND=JPIM), INTENT(IN) :: KDIMM -INTEGER(KIND=JPIM), INTENT(IN) :: KMODE -REAL(KIND=JPRD), INTENT(IN) :: PTOL -REAL(KIND=JPRD), INTENT(OUT) :: PDET1 -REAL(KIND=JPRD), INTENT(INOUT) :: PAB(KDBA,KDIMN+KDIMM) -REAL(KIND=JPRD), INTENT(INOUT) :: PZSCRA(2*KDIMN) -END SUBROUTINE MINV_8 -END INTERFACE diff --git a/src/trans/gpu/algor/interface/minv_caller.h b/src/trans/gpu/algor/interface/minv_caller.h deleted file mode 100644 index 5e5e527c6..000000000 --- a/src/trans/gpu/algor/interface/minv_caller.h +++ /dev/null @@ -1,9 +0,0 @@ -INTERFACE -SUBROUTINE MINV_CALLER(LDSCALE,KDIM,PIN,POU) -USE PARKIND1 , ONLY : JPIM ,JPRB -LOGICAL ,INTENT(IN) :: LDSCALE -INTEGER(KIND=JPIM),INTENT(IN) :: KDIM -REAL(KIND=JPRB),INTENT(IN) :: PIN(KDIM,KDIM) -REAL(KIND=JPRB),INTENT(OUT) :: POU(KDIM,KDIM) -END SUBROUTINE MINV_CALLER -END INTERFACE diff --git a/src/trans/gpu/algor/interface/multvdv.h b/src/trans/gpu/algor/interface/multvdv.h deleted file mode 100644 index 115062e61..000000000 --- a/src/trans/gpu/algor/interface/multvdv.h +++ /dev/null @@ -1,8 +0,0 @@ -INTERFACE -SUBROUTINE MULTVDV(PVEC,PDIA,PROD) -USE PARKIND1, ONLY: JPIM, JPRB -REAL(KIND=JPRB), INTENT(IN) :: PVEC(:,:) -REAL(KIND=JPRB), INTENT(IN) :: PDIA(:) -REAL(KIND=JPRB), INTENT(OUT) :: PROD(:,:) -END SUBROUTINE MULTVDV -END INTERFACE diff --git a/src/trans/gpu/algor/interface/mxmaop.h b/src/trans/gpu/algor/interface/mxmaop.h deleted file mode 100644 index 1365e64e1..000000000 --- a/src/trans/gpu/algor/interface/mxmaop.h +++ /dev/null @@ -1,17 +0,0 @@ -INTERFACE -SUBROUTINE MXMAOP(PA,KA,KAD,PB,KB,KBD,PC,KC,KCA,KAR,KAC,KBC) -USE PARKIND1 ,ONLY : JPIM ,JPRB -REAL(KIND=JPRB) ,INTENT(IN) :: PA(*) -INTEGER(KIND=JPIM),INTENT(IN) :: KA -INTEGER(KIND=JPIM),INTENT(IN) :: KAD -REAL(KIND=JPRB) ,INTENT(IN) :: PB(*) -INTEGER(KIND=JPIM),INTENT(IN) :: KB -INTEGER(KIND=JPIM),INTENT(IN) :: KBD -REAL(KIND=JPRB) ,INTENT(OUT) :: PC(*) -INTEGER(KIND=JPIM),INTENT(IN) :: KC -INTEGER(KIND=JPIM),INTENT(IN) :: KCA -INTEGER(KIND=JPIM),INTENT(IN) :: KAR -INTEGER(KIND=JPIM),INTENT(IN) :: KAC -INTEGER(KIND=JPIM),INTENT(IN) :: KBC -END SUBROUTINE MXMAOP -END INTERFACE diff --git a/src/trans/gpu/algor/interface/mxptma.h b/src/trans/gpu/algor/interface/mxptma.h deleted file mode 100644 index 13b738632..000000000 --- a/src/trans/gpu/algor/interface/mxptma.h +++ /dev/null @@ -1,16 +0,0 @@ -INTERFACE -SUBROUTINE MXPTMA(KLX,KVX,KVXS,KIX,PA,PBI,PCI,PBS,PCS,PX,PY) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KIX -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -REAL(KIND=JPRB) ,INTENT(IN) :: PA(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PBI(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PCI(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PBS(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PCS(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PX(KVXS,KLX,KIX) -REAL(KIND=JPRB) ,INTENT(OUT) :: PY(KVXS,KLX,KIX) -END SUBROUTINE MXPTMA -END INTERFACE diff --git a/src/trans/gpu/algor/interface/mxtrma.h b/src/trans/gpu/algor/interface/mxtrma.h deleted file mode 100644 index 2d7852af9..000000000 --- a/src/trans/gpu/algor/interface/mxtrma.h +++ /dev/null @@ -1,14 +0,0 @@ -INTERFACE -SUBROUTINE MXTRMA(KLX,KVX,KVXS,KIX,PA,PBI,PBS,PX,PY) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KIX -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -REAL(KIND=JPRB) ,INTENT(IN) :: PA(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PBI(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PBS(KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PX(KVXS,KLX,KIX) -REAL(KIND=JPRB) ,INTENT(OUT) :: PY(KVXS,KLX,KIX) -END SUBROUTINE MXTRMA -END INTERFACE diff --git a/src/trans/gpu/algor/interface/mxture.h b/src/trans/gpu/algor/interface/mxture.h deleted file mode 100644 index 3878e667b..000000000 --- a/src/trans/gpu/algor/interface/mxture.h +++ /dev/null @@ -1,16 +0,0 @@ -INTERFACE -SUBROUTINE MXTURE(KLX,KVX,KVXS,KIX,KT,LDMT,PA,PB,PC,PY,PX) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KIX -INTEGER(KIND=JPIM),INTENT(IN) :: KT -LOGICAL ,INTENT(IN) :: LDMT -REAL(KIND=JPRB) ,INTENT(IN) :: PA(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PB(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PC(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PY(KVXS,KLX,KIX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PX(KVXS,KLX,KIX) -END SUBROUTINE MXTURE -END INTERFACE diff --git a/src/trans/gpu/algor/interface/mxturhd.h b/src/trans/gpu/algor/interface/mxturhd.h deleted file mode 100644 index 27239d41d..000000000 --- a/src/trans/gpu/algor/interface/mxturhd.h +++ /dev/null @@ -1,14 +0,0 @@ -INTERFACE -SUBROUTINE MXTURHD(KLX,KVX,KVXS,KT,LDMT,PA,PB,PY,PX) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KT -LOGICAL ,INTENT(IN) :: LDMT -REAL(KIND=JPRB) ,INTENT(IN) :: PA(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PB(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PY(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PX(KVXS,KLX) -END SUBROUTINE MXTURHD -END INTERFACE diff --git a/src/trans/gpu/algor/interface/mxturs.h b/src/trans/gpu/algor/interface/mxturs.h deleted file mode 100644 index ba7fbdaa9..000000000 --- a/src/trans/gpu/algor/interface/mxturs.h +++ /dev/null @@ -1,14 +0,0 @@ -INTERFACE -SUBROUTINE MXTURS(KLX,KVX,KVXS,KIX,PA,PB,PC,PY,PX) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KIX -REAL(KIND=JPRB) ,INTENT(IN) :: PA(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PB(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PC(KVX,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PY(KVXS,KLX,KIX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PX(KVXS,KLX,KIX) -END SUBROUTINE MXTURS -END INTERFACE diff --git a/src/trans/gpu/algor/interface/n1cg1.h b/src/trans/gpu/algor/interface/n1cg1.h deleted file mode 100644 index 524c7cd88..000000000 --- a/src/trans/gpu/algor/interface/n1cg1.h +++ /dev/null @@ -1,40 +0,0 @@ -INTERFACE -subroutine n1cg1 (simul,K_N,YD_X,P_EPSNEG,P_EPS,K_ITER,K_IMP,K_IO,K_MODE,& - & K_PRECO,K_M0,K_ILM0,K_NILM0,YD_YBAR0,YD_SBAR0,P_SIZE0,& - & K_BFGSB,K_M1,K_ILM1,K_NILM1,YD_YBAR1,YD_SBAR1,P_SIZE1,& - & K_SELECT,K_NUPTRA,P_F,YD_R,YD_YS,YD_YRS) -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE CONTROL_VECTORS_MOD - -EXTERNAL SIMUL -INTEGER(KIND=JPIM),INTENT(IN) :: K_NILM0 -INTEGER(KIND=JPIM),INTENT(IN) :: K_NILM1 -INTEGER(KIND=JPIM),INTENT(IN) :: K_N -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_X -REAL(KIND=JPRB) ,INTENT(IN) :: P_EPSNEG -REAL(KIND=JPRB) ,INTENT(IN) :: P_EPS -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_ITER -INTEGER(KIND=JPIM),INTENT(IN) :: K_IMP -INTEGER(KIND=JPIM),INTENT(IN) :: K_IO -INTEGER(KIND=JPIM),INTENT(OUT) :: K_MODE -INTEGER(KIND=JPIM),INTENT(IN) :: K_PRECO -INTEGER(KIND=JPIM),INTENT(IN) :: K_M0 -INTEGER(KIND=JPIM),INTENT(IN) :: K_ILM0(K_NILM0) -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_YBAR0(K_M0) -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_SBAR0(K_M0) -REAL(KIND=JPRB) ,INTENT(IN) :: P_SIZE0 -INTEGER(KIND=JPIM),INTENT(IN) :: K_BFGSB -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_M1 -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_ILM1(K_NILM1) -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_YBAR1(K_M1) -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_SBAR1(K_M1) -REAL(KIND=JPRB) ,INTENT(OUT) :: P_SIZE1 -INTEGER(KIND=JPIM),INTENT(IN) :: K_SELECT -INTEGER(KIND=JPIM),INTENT(IN) :: K_NUPTRA -REAL(KIND=JPRB) ,INTENT(IN) :: P_F -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_R -TYPE(CONTROL_VECTOR) ,INTENT(IN) :: YD_YS -TYPE(CONTROL_VECTOR) ,INTENT(IN) :: YD_YRS - -end subroutine n1cg1 -END INTERFACE diff --git a/src/trans/gpu/algor/interface/n1cga.h b/src/trans/gpu/algor/interface/n1cga.h deleted file mode 100644 index 62de2e7d8..000000000 --- a/src/trans/gpu/algor/interface/n1cga.h +++ /dev/null @@ -1,53 +0,0 @@ -INTERFACE -subroutine n1cga (simul,K_N,YD_X,YD_B,YD_Q,YD_R,YD_V,YD_RM,P_EPSNEG,P_EPS2,K_ITER,K_IMP,K_IO,& - & K_MODE,& - & K_BFGSP,& - & K_M0,K_NYS0,K_JMIN0,K_JMAX0,YD_YBAR0,YD_SBAR0,P_SIZE0,& - & K_BFGSB,& - & K_M1,K_NYS1,K_JMIN1,K_JMAX1,K_JOL,YD_YBAR1,YD_SBAR1,P_SIZE1,P_OL,& - & K_SELECT,& - & P_RHO,P_F0,& - & YD_YS,YD_YRS) -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE CONTROL_VECTORS_MOD - -external simul -INTEGER(KIND=JPIM),INTENT(IN) :: K_M0 -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_M1 -INTEGER(KIND=JPIM),INTENT(IN) :: K_N -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_X -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_B -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_Q -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_R -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_V -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_RM -REAL(KIND=JPRB) ,INTENT(IN) :: P_EPSNEG -REAL(KIND=JPRB) ,INTENT(INOUT) :: P_EPS2 -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_ITER -INTEGER(KIND=JPIM),INTENT(IN) :: K_IMP -INTEGER(KIND=JPIM),INTENT(IN) :: K_IO -INTEGER(KIND=JPIM),INTENT(OUT) :: K_MODE -INTEGER(KIND=JPIM),INTENT(IN) :: K_BFGSP -INTEGER(KIND=JPIM),INTENT(IN) :: K_NYS0 -INTEGER(KIND=JPIM),INTENT(IN) :: K_JMIN0 -INTEGER(KIND=JPIM),INTENT(IN) :: K_JMAX0 -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_YBAR0(K_M0) -TYPE(CONTROL_VECTOR),INTENT(IN) :: YD_SBAR0(K_M0) -REAL(KIND=JPRB) ,INTENT(IN) :: P_SIZE0 -INTEGER(KIND=JPIM),INTENT(IN) :: K_BFGSB -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_NYS1 -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMIN1 -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMAX1 -INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JOL(K_M1) -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_YBAR1(K_M1) -TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_SBAR1(K_M1) -REAL(KIND=JPRB) ,INTENT(OUT) :: P_SIZE1 -REAL(KIND=JPRB) ,INTENT(INOUT) :: P_OL(K_M1) -INTEGER(KIND=JPIM),INTENT(IN) :: K_SELECT -REAL(KIND=JPRB) ,INTENT(OUT) :: P_RHO(K_M0) -REAL(KIND=JPRB) ,INTENT(IN) :: P_F0 -TYPE(CONTROL_VECTOR) ,INTENT(IN) :: YD_YS -TYPE(CONTROL_VECTOR) ,INTENT(IN) :: YD_YRS - -end subroutine n1cga -END INTERFACE diff --git a/src/trans/gpu/algor/interface/si_mxptco.h b/src/trans/gpu/algor/interface/si_mxptco.h deleted file mode 100644 index fd1d7e725..000000000 --- a/src/trans/gpu/algor/interface/si_mxptco.h +++ /dev/null @@ -1,16 +0,0 @@ -INTERFACE -SUBROUTINE SI_MXPTCO(KM,KSMAX,KFLEV,KFLSUR,PF,PALPHA,PDENIM,& - & PEPSI,PIN,POU) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KM -INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX -INTEGER(KIND=JPIM),INTENT(IN) :: KFLEV -INTEGER(KIND=JPIM),INTENT(IN) :: KFLSUR -REAL(KIND=JPRB) ,INTENT(IN) :: PF -REAL(KIND=JPRB) ,INTENT(IN) :: PALPHA(KM:KSMAX+1) -REAL(KIND=JPRB) ,INTENT(IN) :: PDENIM(KM:KSMAX+1) -REAL(KIND=JPRB) ,INTENT(IN) :: PEPSI(KM:KSMAX) -REAL(KIND=JPRB) ,INTENT(IN) :: PIN(KFLSUR,2,KM:KSMAX) -REAL(KIND=JPRB) ,INTENT(OUT) :: POU(KFLSUR,2,KM:KSMAX) -END SUBROUTINE SI_MXPTCO -END INTERFACE diff --git a/src/trans/gpu/algor/interface/simplico.h b/src/trans/gpu/algor/interface/simplico.h deleted file mode 100644 index bb9b6eec1..000000000 --- a/src/trans/gpu/algor/interface/simplico.h +++ /dev/null @@ -1,19 +0,0 @@ -INTERFACE -SUBROUTINE SIMPLICO(KM,KSMAX,KFLEV,KFLSUR,PALPHA,PDENIM,& - & PFPLUS,PFMINUS,PSIVP,PRLAPDI,PBDT2,PY,PX) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KM -INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX -INTEGER(KIND=JPIM),INTENT(IN) :: KFLEV -INTEGER(KIND=JPIM),INTENT(IN) :: KFLSUR -REAL(KIND=JPRB) ,INTENT(IN) :: PALPHA(KM:KSMAX+1) -REAL(KIND=JPRB) ,INTENT(IN) :: PDENIM(KM:KSMAX+1) -REAL(KIND=JPRB) ,INTENT(IN) :: PFPLUS(KM:KSMAX+1) -REAL(KIND=JPRB) ,INTENT(IN) :: PFMINUS(KM:KSMAX+1) -REAL(KIND=JPRB) ,INTENT(IN) :: PSIVP(KFLEV) -REAL(KIND=JPRB) ,INTENT(IN) :: PRLAPDI(0:KSMAX) -REAL(KIND=JPRB) ,INTENT(IN) :: PBDT2 -REAL(KIND=JPRB) ,INTENT(INOUT) :: PY(KFLSUR,2,KM:KSMAX) -REAL(KIND=JPRB) ,INTENT(OUT) :: PX(KFLSUR,2,KM:KSMAX) -END SUBROUTINE SIMPLICO -END INTERFACE diff --git a/src/trans/gpu/algor/interface/sublayer.h b/src/trans/gpu/algor/interface/sublayer.h deleted file mode 100644 index fae7ac2ae..000000000 --- a/src/trans/gpu/algor/interface/sublayer.h +++ /dev/null @@ -1,9 +0,0 @@ -INTERFACE - SUBROUTINE SUBLAYER(pz1,pz2,pz3,px1,px2,ldgradps,& - & pt1,pt2,pw1,pw2,pzs1,pzs2,pzps) - USE PARKIND1 ,ONLY : JPIM ,JPRB - LOGICAL, INTENT(in) :: ldgradps - REAL(KIND=JPRB), INTENT(in) :: pz1,pz2,pz3,px1,px2,pt1,pt2,pzs1,pzs2 - REAL(KIND=JPRB), INTENT(out) :: pw1,pw2,pzps - END SUBROUTINE SUBLAYER -END INTERFACE diff --git a/src/trans/gpu/algor/interface/suher.h b/src/trans/gpu/algor/interface/suher.h deleted file mode 100644 index 57e2b97c6..000000000 --- a/src/trans/gpu/algor/interface/suher.h +++ /dev/null @@ -1,18 +0,0 @@ -INTERFACE -SUBROUTINE SUHER(KLX,KVX,KVXS,PD,PEI,PES,PFI,PFS,PA,PB,PC,PG,PH) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -REAL(KIND=JPRB) ,INTENT(IN) :: PD(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PEI(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PES(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PFI(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PFS(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PA(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PB(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PC(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PG(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PH(KVXS,KLX) -END SUBROUTINE SUHER -END INTERFACE diff --git a/src/trans/gpu/algor/interface/suhert.h b/src/trans/gpu/algor/interface/suhert.h deleted file mode 100644 index f73ad5f55..000000000 --- a/src/trans/gpu/algor/interface/suhert.h +++ /dev/null @@ -1,14 +0,0 @@ -INTERFACE -SUBROUTINE SUHERT(KLX,KVX,KVXS,PD,PEI,PES,PA,PB,PG) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -REAL(KIND=JPRB) ,INTENT(IN) :: PD(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PEI(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PES(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PA(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PB(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PG(KVXS,KLX) -END SUBROUTINE SUHERT -END INTERFACE diff --git a/src/trans/gpu/algor/interface/suhes.h b/src/trans/gpu/algor/interface/suhes.h deleted file mode 100644 index 25bb0ec1b..000000000 --- a/src/trans/gpu/algor/interface/suhes.h +++ /dev/null @@ -1,14 +0,0 @@ -INTERFACE -SUBROUTINE SUHES(KLX,KVX,KVXS,PD,PE,PF,PA,PB,PC) -USE PARKIND1 ,ONLY : JPIM ,JPRB -INTEGER(KIND=JPIM),INTENT(IN) :: KLX -INTEGER(KIND=JPIM),INTENT(IN) :: KVXS -INTEGER(KIND=JPIM),INTENT(IN) :: KVX -REAL(KIND=JPRB) ,INTENT(IN) :: PD(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PE(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(IN) :: PF(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PA(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PB(KVXS,KLX) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PC(KVXS,KLX) -END SUBROUTINE SUHES -END INTERFACE diff --git a/src/trans/gpu/algor/interface/tridia.h b/src/trans/gpu/algor/interface/tridia.h deleted file mode 100644 index 836bfa887..000000000 --- a/src/trans/gpu/algor/interface/tridia.h +++ /dev/null @@ -1,25 +0,0 @@ -INTERFACE -SUBROUTINE TRIDIA(KN,KSYS,KFIRST,KEND,KTYP,PM,PRHS,PSOL) - -! ----------------------------------------------------------------------------- - -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK - -! ----------------------------------------------------------------------------- - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KN -INTEGER(KIND=JPIM),INTENT(IN) :: KSYS -INTEGER(KIND=JPIM),INTENT(IN) :: KFIRST -INTEGER(KIND=JPIM),INTENT(IN) :: KEND -INTEGER(KIND=JPIM),INTENT(IN) :: KTYP -REAL(KIND=JPRB) ,INTENT(IN) :: PM(1+(KTYP-1)*(KSYS-1),KN,-1:1) -REAL(KIND=JPRB) ,INTENT(IN) :: PRHS(KSYS,KN) -REAL(KIND=JPRB) ,INTENT(OUT) :: PSOL(KSYS,KN) - -! ----------------------------------------------------------------------------- - -END SUBROUTINE TRIDIA -END INTERFACE diff --git a/src/trans/gpu/algor/internal/fourier/qpassf.F b/src/trans/gpu/algor/internal/fourier/qpassf.F deleted file mode 100644 index 78142b967..000000000 --- a/src/trans/gpu/algor/internal/fourier/qpassf.F +++ /dev/null @@ -1,3 +0,0 @@ - SUBROUTINE QPASSF -C inlined in fft992 - ENDSUBROUTINE QPASSF diff --git a/src/trans/gpu/algor/internal/fourier/rpassf.F b/src/trans/gpu/algor/internal/fourier/rpassf.F deleted file mode 100644 index c1a7d0fcc..000000000 --- a/src/trans/gpu/algor/internal/fourier/rpassf.F +++ /dev/null @@ -1,3 +0,0 @@ - SUBROUTINE RPASSF -C inlined in fft992 - ENDSUBROUTINE RPASSF diff --git a/src/trans/gpu/algor/module/cublasDgemmBatched.cu b/src/trans/gpu/algor/module/cublasDgemmBatched.cu deleted file mode 100644 index 98fe25c2f..000000000 --- a/src/trans/gpu/algor/module/cublasDgemmBatched.cu +++ /dev/null @@ -1,141 +0,0 @@ -// -// Wrapper for cublasDgemm function. -// -// Alan Gray, NVIDIA -// - -#include -#include "cublas_v2.h" - - -bool alreadyAllocated_dgemm=false; -bool alreadyAllocated_dgemm_handle=false; - -double **d_Aarray; -double **d_Barray; -double **d_Carray; - -double **Aarray; -double **Barray; -double **Carray; - -cublasHandle_t handle_dgemm; - -extern "C" void cublasDgemmBatched_wrapper (char transa, char transb, int m, int n,int k, double alpha, const double *A, int lda, int tda, const double *B, int ldb, int tdb, double beta, double *C, int ldc, int tdc, int batchCount) -{ - - - // printf("CUBLAS m=%d,n=%d,k=%d,batchcount=%d\n",m,n,k,batchCount); - cublasStatus_t stat; - - - cublasOperation_t op_t1=CUBLAS_OP_N, op_t2=CUBLAS_OP_N; - - if (transa=='T' || transa=='t') - op_t1=CUBLAS_OP_T; - - if (transb=='T' || transb=='t') - op_t2=CUBLAS_OP_T; - - - //double **Aarray = (double**) malloc(batchCount*sizeof(double*)); - //double **Barray = (double**) malloc(batchCount*sizeof(double*)); - //double **Carray = (double**) malloc(batchCount*sizeof(double*)); - - - - if (!alreadyAllocated_dgemm_handle){ - stat = cublasCreate(&handle_dgemm); - if (stat != CUBLAS_STATUS_SUCCESS) { - printf ("CUBLAS initialization failed\n"); - //return EXIT_FAILURE; - } - } - alreadyAllocated_dgemm_handle=true; - - if (!alreadyAllocated_dgemm){ - cudaError_t errcm1 = cudaMallocHost(&Aarray,batchCount*sizeof(double*)); - cudaError_t errcm2 = cudaMallocHost(&Barray,batchCount*sizeof(double*)); - cudaError_t errcm3 = cudaMallocHost(&Carray,batchCount*sizeof(double*)); - - cudaError_t errcm4 = cudaMalloc(&d_Aarray,batchCount*sizeof(double*)); - cudaError_t errcm5 = cudaMalloc(&d_Barray,batchCount*sizeof(double*)); - cudaError_t errcm6 = cudaMalloc(&d_Carray,batchCount*sizeof(double*)); - } - alreadyAllocated_dgemm=true; - - int i; - for(i=0;i -#include "cublas_v2.h" - -bool alreadyAllocated_stcgemm = false; -bool alreadyAllocated_stcgemm_handle = false; - -half **d_Aarray_stcgemm; -half **d_Barray_stcgemm; -float **d_Carray_stcgemm; - -half **Aarray_stcgemm; -half **Barray_stcgemm; -float **Carray_stcgemm; - -cublasHandle_t handle_stcgemm; - -extern "C" void cublasSTCgemmBatched_wrapper( - char transa, char transb, - int m, int n, int k, - float alpha, - const half *A, int lda, int tda, - const half *B, int ldb, int tdb, - float beta, - float *C, int ldc, int tdc, - int batchCount -){ - // Define CUBLAS operation handles - cublasOperation_t op_t1, op_t2; - - // Decide whether to transpose matrices or not - op_t1 = (transa == 'T' || transa == 't') ? CUBLAS_OP_T : CUBLAS_OP_N; - op_t2 = (transb == 'T' || transb == 't') ? CUBLAS_OP_T : CUBLAS_OP_N; - - // Initialize CUBLAS handle - if (!alreadyAllocated_stcgemm_handle) { - cublasCreate(&handle_stcgemm); - alreadyAllocated_stcgemm_handle = true; - } - - // Allocate host arrays - if (!alreadyAllocated_stcgemm) { - cudaMallocHost(&Aarray_stcgemm,batchCount*sizeof(half*)); - cudaMallocHost(&Barray_stcgemm,batchCount*sizeof(half*)); - cudaMallocHost(&Carray_stcgemm,batchCount*sizeof(float*)); - alreadyAllocated_stcgemm = true; - } - - // Allocate device arrays - cudaMalloc(&d_Aarray_stcgemm, batchCount*sizeof(half*)); - cudaMalloc(&d_Barray_stcgemm, batchCount*sizeof(half*)); - cudaMalloc(&d_Carray_stcgemm, batchCount*sizeof(float*)); - - // Transfer data from input arrays to host arrays - for (int i = 0; i < batchCount; i++) { - Aarray_stcgemm[i] = (half*) &(A[i*lda*tda]); - Barray_stcgemm[i] = (half*) &(B[i*ldb*tdb]); - Carray_stcgemm[i] = (float*) &(C[i*ldc*tdc]); - } - - // Transfer data from host arrays to device arrays - cudaMemcpy(d_Aarray_stcgemm, Aarray_stcgemm, batchCount*sizeof(half*), cudaMemcpyHostToDevice); - cudaMemcpy(d_Barray_stcgemm, Barray_stcgemm, batchCount*sizeof(half*), cudaMemcpyHostToDevice); - cudaMemcpy(d_Carray_stcgemm, Carray_stcgemm, batchCount*sizeof(float*), cudaMemcpyHostToDevice); - - // Perform batched SGEMM - cublasGemmBatchedEx(handle_stcgemm, - op_t1, op_t2, - m, n, k, - (const void*)&alpha, - (const void**)d_Aarray_stcgemm, CUDA_R_16F, lda, - (const void**)d_Barray_stcgemm, CUDA_R_16F, ldb, - (const void*)&beta, - (void**)d_Carray_stcgemm, CUDA_R_32F, ldc, - batchCount, - CUBLAS_COMPUTE_32F, CUBLAS_GEMM_DEFAULT_TENSOR_OP - ); - - cudaDeviceSynchronize(); - - // Free device arrays - cudaFree(d_Aarray_stcgemm); - cudaFree(d_Barray_stcgemm); - cudaFree(d_Carray_stcgemm); -} - -extern "C" void cublasSTCgemmBatched_finalize() { - if (alreadyAllocated_stcgemm) { - cudaFree(Aarray_stcgemm); - cudaFree(Barray_stcgemm); - cudaFree(Carray_stcgemm); - - cudaFree(d_Aarray_stcgemm); - cudaFree(d_Barray_stcgemm); - cudaFree(d_Carray_stcgemm); - } - - if (alreadyAllocated_stcgemm_handle) { - cublasDestroy(handle_stcgemm); - } -} diff --git a/src/trans/gpu/algor/module/cublasSgemmBatched.cu b/src/trans/gpu/algor/module/cublasSgemmBatched.cu deleted file mode 100644 index 61c8384ac..000000000 --- a/src/trans/gpu/algor/module/cublasSgemmBatched.cu +++ /dev/null @@ -1,125 +0,0 @@ -// -// Wrapper for cublasSgemm function. -// -// Alan Gray, NVIDIA -// - -#include -#include "cublas_v2.h" - - -bool alreadyAllocated_sgemm=false; -bool alreadyAllocated_sgemm_handle=false; - -float **d_Aarray_sgemm; -float **d_Barray_sgemm; -float **d_Carray_sgemm; - -float **Aarray_sgemm; -float **Barray_sgemm; -float **Carray_sgemm; - -cublasHandle_t handle_sgemm; - -extern "C" void cublasSgemmBatched_wrapper (char transa, char transb, int m, int n,int k, float alpha, const float *A, int lda, int tda, const float *B, int ldb, int tdb, float beta, float *C, int ldc, int tdc, int batchCount) -{ - - // printf("CUBLAS m=%d,n=%d,k=%d,batchcount=%d\n",m,n,k,batchCount); - - cublasOperation_t op_t1=CUBLAS_OP_N, op_t2=CUBLAS_OP_N; - - if (transa=='T' || transa=='t') - op_t1=CUBLAS_OP_T; - - if (transb=='T' || transb=='t') - op_t2=CUBLAS_OP_T; - - //float **Aarray_sgemm = (float**) malloc(batchCount*sizeof(float*)); - //float **Barray_sgemm = (float**) malloc(batchCount*sizeof(float*)); - //float **Carray_sgemm = (float**) malloc(batchCount*sizeof(float*)); - - if (!alreadyAllocated_sgemm_handle){ - cublasCreate(&handle_sgemm); - alreadyAllocated_sgemm_handle=true; - } - - if (!alreadyAllocated_sgemm){ - cudaMallocHost(&Aarray_sgemm,batchCount*sizeof(float*)); - cudaMallocHost(&Barray_sgemm,batchCount*sizeof(float*)); - cudaMallocHost(&Carray_sgemm,batchCount*sizeof(float*)); - alreadyAllocated_sgemm=true; - } - - cudaMalloc(&d_Aarray_sgemm,batchCount*sizeof(float*)); - cudaMalloc(&d_Barray_sgemm,batchCount*sizeof(float*)); - cudaMalloc(&d_Carray_sgemm,batchCount*sizeof(float*)); - - int i; - for(i=0;i -#include "cublas_v2.h" - - -bool alreadyAllocated_tcgemm=false; -bool alreadyAllocated_tcgemm_handle=false; - -// Device arrays -//half **d_Aarray_h; -//half **d_Barray_h; -float **d_Aarray_h; -float **d_Barray_h; -float **d_Aarray_tcgemm; -float **d_Barray_tcgemm; -float **d_Carray_tcgemm; - -// Host arrays -float **Aarray_tcgemm; -float **Barray_tcgemm; -float **Carray_tcgemm; - -cublasHandle_t handle_tcgemm; - -// Converts from single-precision to half-precision (CUDA kernel) -__global__ void float2half(half *out, const float *in, int n) { - int idx = blockDim.x * blockIdx.x + threadIdx.x; - if (idx < n) { - out[idx] = __float2half(in[idx]); - } -} - - - -extern "C" void cublasTCgemmBatched_wrapper(char transa, char transb, - int m, int n, int k, - float alpha, - const float *A, int lda, int tda, - const float *B, int ldb, int tdb, - float beta, - float *C, int ldc, int tdc, - int batchCount) -{ - fprintf(stderr, "Using Tensor Core\n"); - - // Set transpose operation parameters - cublasOperation_t op_t1 = (transa == 'T' || transa == 't') ? CUBLAS_OP_T : CUBLAS_OP_N; - cublasOperation_t op_t2 = (transb == 'T' || transb == 't') ? CUBLAS_OP_T : CUBLAS_OP_N; - - if (!alreadyAllocated_tcgemm_handle) { - cublasCreate(&handle_tcgemm); - alreadyAllocated_tcgemm_handle=true; - } - - //cublasSetMathMode(handle_tcgemm, CUBLAS_TENSOR_OP_MATH); - - if (!alreadyAllocated_tcgemm) { - // Allocate host arrays specifically for host->device transfer - cudaMallocHost(&Aarray_tcgemm, batchCount*sizeof(float*)); - cudaMallocHost(&Barray_tcgemm, batchCount*sizeof(float*)); - cudaMallocHost(&Carray_tcgemm, batchCount*sizeof(float*)); - alreadyAllocated_tcgemm=true; - } - - // Allocate device arrays - cudaMalloc(&d_Aarray_h, batchCount*sizeof(float*)); - cudaMalloc(&d_Barray_h, batchCount*sizeof(float*)); - cudaMalloc(&d_Aarray_tcgemm, batchCount*sizeof(float*)); - cudaMalloc(&d_Barray_tcgemm, batchCount*sizeof(float*)); - cudaMalloc(&d_Carray_tcgemm, batchCount*sizeof(float*)); - - // Copy data from dummy arrays to host arrays - for (int i = 0; i < batchCount; i++) { - Aarray_tcgemm[i] = (float*) &(A[i*lda*tda]); - Barray_tcgemm[i] = (float*) &(B[i*ldb*tdb]); - Carray_tcgemm[i] = (float*) &(C[i*ldc*tdc]); - } - - // Transfer arrays from host to device - cudaMemcpy(d_Aarray_tcgemm, Aarray_tcgemm, batchCount*sizeof(float*), cudaMemcpyHostToDevice); - cudaMemcpy(d_Barray_tcgemm, Barray_tcgemm, batchCount*sizeof(float*), cudaMemcpyHostToDevice); - cudaMemcpy(d_Carray_tcgemm, Carray_tcgemm, batchCount*sizeof(float*), cudaMemcpyHostToDevice); - -// // Convert arrays to half-precision -// for (int i = 0; i < batchCount; i++) { -// float2half<<<(int)(m*k/256) + 1, 256 >>>(d_Aarray_h[i], d_Aarray_tcgemm[i], batchCount); -// float2half<<<(int)(k*n/256) + 1, 256 >>>(d_Barray_h[i], d_Barray_tcgemm[i], batchCount); -// } - - // Perform Tensor Core batched GEMM - cublasGemmBatchedEx(handle_tcgemm, op_t1, op_t2, - m, n, k, - (const void *)&alpha, - (const void **)d_Aarray_h, CUDA_R_32F, lda, - (const void **)d_Barray_h, CUDA_R_32F, ldb, - (const void *)&beta, - (void **)d_Carray_tcgemm, CUDA_R_32F, ldc, - batchCount, - CUBLAS_COMPUTE_32F, CUBLAS_GEMM_DEFAULT); - - cudaDeviceSynchronize(); - - cudaFree(d_Aarray_h); - cudaFree(d_Barray_h); - cudaFree(d_Aarray_tcgemm); - cudaFree(d_Barray_tcgemm); - cudaFree(d_Carray_tcgemm); -} - -extern "C" void cublasTCgemmBatched_finalize() -{ - if (alreadyAllocated_tcgemm) { - cudaFree(Aarray_tcgemm); - cudaFree(Barray_tcgemm); - cudaFree(Carray_tcgemm); - - cudaFree(d_Aarray_h); - cudaFree(d_Barray_h); - cudaFree(d_Aarray_tcgemm); - cudaFree(d_Barray_tcgemm); - cudaFree(d_Carray_tcgemm); - } - - if (alreadyAllocated_tcgemm_handle) { - cublasDestroy(handle_tcgemm); - } -} - diff --git a/src/trans/gpu/algor/module/cublas_mod.F90 b/src/trans/gpu/algor/module/cublas_mod.F90 deleted file mode 100644 index e69a00e16..000000000 --- a/src/trans/gpu/algor/module/cublas_mod.F90 +++ /dev/null @@ -1,158 +0,0 @@ -MODULE CUBLAS_MOD -! -! Define the interfaces to the NVIDIA C code -! -interface cuda_gemm -! -! void cublasSgemm (char transa, char transb, int m, int n, -! int k, float alpha, const float *A, int lda, -! const float *B, int ldb, float beta, float *C, int ldc) -! -subroutine cuda_sgemm(cta, ctb, m, n, k,& -alpha, A, lda, B, ldb, beta, c, ldc) bind(C,name='cublasSgemm') -use iso_c_binding -character(1,c_char),value :: cta, ctb -integer(c_int),value :: m,n,k,lda,ldb,ldc -real(c_float),value :: alpha,beta -real(c_float), dimension(lda,*) :: A -real(c_float), dimension(ldb,*) :: B -real(c_float), dimension(ldc,*) :: C -end subroutine cuda_sgemm - -! -! void cublasDgemm (char transa, char transb, int m, int n, -! int k, double alpha, const double *A, int lda, -! const double *B, int ldb, double beta, double *C, int ldc) -! -subroutine cuda_dgemm(cta, ctb, m, n, k,& -alpha, A, lda, B, ldb, beta, c, ldc) bind(C,name='cublasDgemm') -use iso_c_binding -character(1,c_char),value :: cta, ctb -integer(c_int),value :: m,n,k,lda,ldb,ldc -real(c_double),value :: alpha,beta -real(c_double), dimension(lda,*) :: A -real(c_double), dimension(ldb,*) :: B -real(c_double), dimension(ldc,*) :: C -end subroutine cuda_dgemm -end interface - - -INTERFACE - SUBROUTINE CUDA_DGEMM_BATCHED(& - & CTA, CTB, & - & M, N, K, & - & ALPHA, & - & A, LDA, TDA, & - & B, LDB, TDB, & - & BETA, & - & C, LDC, TDC, & - & BATCHCOUNT & - &) BIND(C, NAME='cublasDgemmBatched_wrapper') - USE ISO_C_BINDING - CHARACTER(1,C_CHAR), VALUE :: CTA, CTB - INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT - REAL(C_DOUBLE), VALUE :: ALPHA,BETA - REAL(C_DOUBLE), DIMENSION(LDA,*) :: A - REAL(C_DOUBLE), DIMENSION(LDB,*) :: B - REAL(C_DOUBLE), DIMENSION(LDC,*) :: C - END SUBROUTINE CUDA_DGEMM_BATCHED - - SUBROUTINE CUDA_DGEMM_STRIDED_BATCHED(& - & CTA, CTB, & - & M, N, K, & - & ALPHA, & - & A, LDA, TDA, & - & B, LDB, TDB, & - & BETA, & - & C, LDC, TDC, & - & BATCHCOUNT & - &) BIND(C, NAME='cublasDgemmStridedBatched_wrapper') - USE ISO_C_BINDING - CHARACTER(1,C_CHAR), VALUE :: CTA, CTB - INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, BATCHCOUNT - INTEGER(C_LONG_LONG), VALUE :: TDA,TDB,TDC - REAL(C_DOUBLE), VALUE :: ALPHA, BETA - REAL(C_DOUBLE), DIMENSION(LDA,*) :: A - REAL(C_DOUBLE), DIMENSION(LDB,*) :: B - REAL(C_DOUBLE), DIMENSION(LDC,*) :: C - END SUBROUTINE CUDA_DGEMM_STRIDED_BATCHED - - subroutine cuda_dgemm_batched_finalize() bind(C,name='cublasDgemmBatched_finalize') - end subroutine cuda_dgemm_batched_finalize - -END INTERFACE - -INTERFACE - - SUBROUTINE CUDA_SGEMM_BATCHED(& - & CTA, CTB, & - & M, N, K, & - & ALPHA, & - & A, LDA, TDA, & - & B, LDB, TDB, & - & BETA, & - & C, LDC, TDC, & - & BATCHCOUNT & - &) BIND(C, NAME='cublasSgemmBatched_wrapper') - USE ISO_C_BINDING - CHARACTER(1,C_CHAR), VALUE :: CTA, CTB - INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT - REAL(C_FLOAT), VALUE :: ALPHA, BETA - REAL(C_FLOAT), DIMENSION(LDA,*) :: A - REAL(C_FLOAT), DIMENSION(LDB,*) :: B - REAL(C_FLOAT), DIMENSION(LDC,*) :: C - END SUBROUTINE CUDA_SGEMM_BATCHED -!!END INTERFACE - -!!INTERFACE - SUBROUTINE CUDA_SGEMM_STRIDED_BATCHED(& - & CTA, CTB, & - & M, N, K, & - & ALPHA, & - & A, LDA, TDA, & - & B, LDB, TDB, & - & BETA, & - & C, LDC, TDC, & - & BATCHCOUNT & - &) BIND(C, NAME='cublasSgemmStridedBatched_wrapper') - USE ISO_C_BINDING - CHARACTER(1,C_CHAR), VALUE :: CTA, CTB - INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, BATCHCOUNT - INTEGER(C_LONG_LONG), VALUE :: TDA,TDB,TDC - REAL(C_FLOAT), VALUE :: ALPHA, BETA - REAL(C_FLOAT), DIMENSION(LDA,*) :: A - REAL(C_FLOAT), DIMENSION(LDB,*) :: B - REAL(C_FLOAT), DIMENSION(LDC,*) :: C - END SUBROUTINE CUDA_SGEMM_STRIDED_BATCHED - - subroutine cuda_sgemm_batched_finalize() bind(C,name='cublasSgemmBatched_finalize') - end subroutine cuda_sgemm_batched_finalize - - -END INTERFACE - -INTERFACE - SUBROUTINE CUDA_STCGEMM_BATCHED(& - & CTA, CTB, & - & M, N, K, & - & ALPHA, & - & A, LDA, TDA, & - & B, LDB, TDB, & - & BETA, & - & C, LDC, TDC, & - & BATCHCOUNT & - &) BIND(C, NAME='cublasSTCgemmBatched_wrapper') - USE ISO_C_BINDING - CHARACTER(1,C_CHAR), VALUE :: CTA, CTB - INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT - REAL(C_FLOAT), VALUE :: ALPHA, BETA - REAL(2), DIMENSION(LDA,*) :: A - REAL(2), DIMENSION(LDB,*) :: B - REAL(C_FLOAT), DIMENSION(LDC,*) :: C - END SUBROUTINE CUDA_STCGEMM_BATCHED -END INTERFACE - - - - -END MODULE CUBLAS_MOD diff --git a/src/trans/gpu/algor/module/cuda_device_mod.F90 b/src/trans/gpu/algor/module/cuda_device_mod.F90 deleted file mode 100644 index f710b687d..000000000 --- a/src/trans/gpu/algor/module/cuda_device_mod.F90 +++ /dev/null @@ -1,40 +0,0 @@ -module cuda_device_mod - -interface cuda_sync - -integer function cuda_synchronize() bind(C,name='cudaDeviceSynchronize') -use iso_c_binding -end function cuda_synchronize - -integer function cuda_stream_synchronize(stream) bind(C,name='cudaStreamSynchronize') -use iso_c_binding -type(c_ptr) :: stream -end function cuda_stream_synchronize - -integer function cuda_stream_destroy(stream) bind(C,name='cudaStreamDestroy') -use iso_c_binding -type(c_ptr) :: stream -end function cuda_stream_destroy - -end interface cuda_sync - -interface cuda_device - -integer function cuda_SetDevice(devnum) bind(C,name='cudaSetDevice') -use iso_c_binding -integer(c_int),value :: devnum -end function cuda_SetDevice - -integer function cuda_GetDevice(devnum) bind(C,name='cudaGetDevice') -use iso_c_binding -integer(c_int) :: devnum -end function cuda_GetDevice - -integer function cuda_GetDeviceCount(devnum) bind(C,name='cudaGetDeviceCount') -use iso_c_binding -integer(c_int) :: devnum -end function cuda_GetDeviceCount - -end interface cuda_device - -end module cuda_device_mod diff --git a/src/trans/gpu/external/dir_trans.F90 b/src/trans/gpu/external/dir_trans.F90 index ffabc1f5e..958e9cdf1 100755 --- a/src/trans/gpu/external/dir_trans.F90 +++ b/src/trans/gpu/external/dir_trans.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -115,13 +116,15 @@ SUBROUTINE DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV -USE TPM_FIELDS ,ONLY : IF_FS_DIR,IF_FS_DIR0,NFLEV,NFLEV0,DTDZBA,DTDZBS,DTDZCA,DTDZCS USE TPM_FLT, ONLY: S USE TPM_GEOMETRY ,ONLY : G USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DIR_TRANS_CTL_MOD ,ONLY : DIR_TRANS_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE MPL_MODULE ,ONLY : MPL_BARRIER +USE TPM_GEN ,ONLY : LSYNC_TRANS +USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX !endif INTERFACE @@ -161,7 +164,10 @@ SUBROUTINE DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIR_TRANS',0,ZHOOK_HANDLE) -CALL GSTATS(440,0) +IF (LSYNC_TRANS) THEN + CALL MPL_BARRIER(CDSTRING='') +ENDIF +CALL GSTATS(410,0) CALL GSTATS(1808,0) ! Set current resolution CALL SET_RESOL(KRESOL) @@ -303,31 +309,8 @@ SUBROUTINE DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS -!D%IADJUST_D=0 -!IF(MOD(IF_FS,2)==1) THEN -! IF_FS = IF_FS + 1 -! D%IADJUST_D=1 -!ENDIF - IF_GP = 2*IF_UV_G+IF_SCALARS_G -! add additional post-processing requirements -! (copied from setup_trans.F90. Or does this need to be different here than in setup_trans.F90?) -!IF_PP = 2*NFLEV -!IF_PP = 0 - -! How do I get the current number of levels? For now I use: (Andreas) -!NFLEV = NFLEV0 - -! set currently used array sizes for the GPU arrays: -IF_FS_DIR=2*IF_FS+2!2*(2*IF_UV+NFLEV+2+IF_PP) -print*,"dir_trans: IF_FS_DIR=",IF_FS_DIR," IF_FS_DIR0=",IF_FS_DIR0 - -DTDZBA=IF_FS_DIR -DTDZBS=IF_FS_DIR -DTDZCA=IF_FS_DIR -DTDZCS=IF_FS_DIR - ! Consistency checks IF (IF_UV > 0) THEN @@ -527,7 +510,12 @@ SUBROUTINE DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LHOOK) CALL DR_HOOK('DIR_TRANS',1,ZHOOK_HANDLE) -CALL GSTATS(440,1) +IF (LSYNC_TRANS) THEN + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) +ENDIF +CALL GSTATS(410,1) ! ------------------------------------------------------------------ !endif INTERFACE diff --git a/src/trans/gpu/external/dir_transad.F90 b/src/trans/gpu/external/dir_transad.F90 deleted file mode 100755 index 4b0ac951d..000000000 --- a/src/trans/gpu/external/dir_transad.F90 +++ /dev/null @@ -1,505 +0,0 @@ -! (C) Copyright 2000- 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 DIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& -& KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& -& PGP,PGPUV,PGP3A,PGP3B,PGP2) - - -!**** *DIR_TRANSAD* - Direct spectral transform - adjoint. - -! Purpose. -! -------- -! Interface routine for the direct spectral transform - adjoint - -!** Interface. -! ---------- -! CALL DIR_TRANSAD(...) - -! Explicit arguments : All arguments except from PGP are optional. -! -------------------- -! PSPVOR(:,:) - spectral vorticity (output) -! PSPDIV(:,:) - spectral divergence (output) -! PSPSCALAR(:,:) - spectral scalarvalued fields (output) -! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) -! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) -! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) -! KPROMA - required blocking factor for gridpoint output -! KVSETUV(:) - indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. -! KVESETSC(:) - indicating which 'b-set' in spectral space owns a -! scalar field. As for KVSETUV this argument is required -! if the total number of processors is greater than -! the number of processors used for distribution in -! spectral wave space. -! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) -! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) -! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) -! KRESOL - resolution tag which is required ,default is the -! first defined resulution (input) -! PGP(:,:,:) - gridpoint fields (input) -! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where -! NPROMA is the blocking factor, IF_GP the total number -! of output fields and NGPBLKS the number of NPROMA blocks. -! The ordering of the output fields is as follows (all -! parts are optional depending on the input switches): -! -! u : IF_UV_G fields (if psvor present) -! v : IF_UV_G fields (if psvor present) -! scalar fields : IF_SCALARS_G fields (if pspscalar present) -! -! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length -! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction -! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the -! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral -! 'b-set' split -! -! As an alternative to using PGP you can also use a combination of the -! following arrays. The reason for introducing these alternative ways -! of calling DIR_TRANS is to avoid uneccessary copies where your data -! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. -! The use of any of these precludes the use of PGP and vice versa. - -! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order -! described for PGP. The second dimension of PGPUV should -! be the same as the "global" first dimension of -! PSPVOR,PSPDIV (in the IFS this is the number of levels) -! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (u,v) -! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A -! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (the same as in -! PSPSC3A ) -! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B -! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (the same as in -! PSPSC3B) -! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 -! dimensioned(NPROMA,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (the same as in -! PSPSC2 ) -! -! Method. -! ------- - -! Externals. SET_RESOL - set resolution -! ---------- DIR_TRANS_CTLAD - control routine -! - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 - -! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -!ifndef INTERFACE - -USE TPM_GEN ,ONLY : NERR, NOUT -USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & - & NGPBLKS, NF_SC2, NF_SC3A, NF_SC3B, NPROMA -USE TPM_DISTR ,ONLY : D, MYSETV, NPRTRV - -USE SET_RESOL_MOD ,ONLY : SET_RESOL -USE DIR_TRANS_CTLAD_MOD ,ONLY : DIR_TRANS_CTLAD -USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -!endif INTERFACE - -IMPLICIT NONE - -! Declaration of arguments - -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL - -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) - -!ifndef INTERFACE - -! Local variables -INTEGER(KIND=JPIM) :: IUBOUND(4),J -INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP -INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ------------------------------------------------------------------ -IF (LHOOK) CALL DR_HOOK('DIR_TRANSAD',0,ZHOOK_HANDLE) - -CALL GSTATS(1810,0) -! Set current resolution - -CALL SET_RESOL(KRESOL) - -! Set defaults - -IF_UV = 0 -IF_UV_G = 0 -IF_SCALARS = 0 -IF_SCALARS_G = 0 -NF_SC2 = 0 -NF_SC3A = 0 -NF_SC3B = 0 -IF_SC2_G = 0 -IF_SC3A_G = 0 -IF_SC3B_G = 0 -NPROMA = D%NGPTOT -LSCDERS=.FALSE. ! This is for use in TRLTOG which is shared with inverse transform -LVORGP=.FALSE. -LDIVGP=.FALSE. -LUVDER=.FALSE. - -! Decide requirements - - -IF(PRESENT(KVSETUV)) THEN - IF_UV_G = UBOUND(KVSETUV,1) - DO J=1,IF_UV_G - IF(KVSETUV(J) > NPRTRV) THEN - WRITE(NERR,*) 'DIR_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD:KVSETUV CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETUV(J) == MYSETV) THEN - IF_UV = IF_UV+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPVOR)) THEN - IF_UV = UBOUND(PSPVOR,1) - IF_UV_G = IF_UV -ENDIF - -IF(PRESENT(KVSETSC)) THEN - IF_SCALARS_G = UBOUND(KVSETSC,1) - DO J=1,IF_SCALARS_G - IF(KVSETSC(J) > NPRTRV) THEN - WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSCALAR)) THEN - IF_SCALARS = UBOUND(PSPSCALAR,1) - IF_SCALARS_G = IF_SCALARS -ENDIF - -IF(PRESENT(KVSETSC2)) THEN - IF(.NOT.PRESENT(PSPSC2)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC2 BUT NOT PSPSC2') - ENDIF - IF_SC2_G = UBOUND(KVSETSC2,1) - IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G - DO J=1,UBOUND(KVSETSC2,1) - IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN - WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC2(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+1 - NF_SC2 = NF_SC2+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSC2)) THEN - IF_SC2_G = UBOUND(PSPSC2,1) - NF_SC2 = UBOUND(PSPSC2,1) - IF_SCALARS = IF_SCALARS+NF_SC2 - IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G -ENDIF - -IF(PRESENT(KVSETSC3A)) THEN - IF(.NOT.PRESENT(PSPSC3A)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC3A BUT NOT PSPSC3A') - ENDIF - IF_SC3A_G = UBOUND(KVSETSC3A,1) - IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) - DO J=1,UBOUND(KVSETSC3A,1) - IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN - WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC3A(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) - NF_SC3A = NF_SC3A+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSC3A)) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) - IF_SC3A_G = UBOUND(PSPSC3A,1) - IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) - NF_SC3A = UBOUND(PSPSC3A,1) -ENDIF - -IF(PRESENT(KVSETSC3B)) THEN - IF(.NOT.PRESENT(PSPSC3B)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC3B BUT NOT PSPSC3B') - ENDIF - IF_SC3B_G = UBOUND(KVSETSC3B,1) - IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) - DO J=1,UBOUND(KVSETSC3B,1) - IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN - WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC3B(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) - NF_SC3B = NF_SC3B+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSC3B)) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) - IF_SC3B_G = UBOUND(PSPSC3B,1) - IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) - NF_SC3B = UBOUND(PSPSC3B,1) -ENDIF - -IF(PRESENT(KPROMA)) THEN - NPROMA = KPROMA -ENDIF - -! Compute derived variables - - -NGPBLKS = (D%NGPTOT-1)/NPROMA+1 - -IF_FS = 2*IF_UV + IF_SCALARS - -IF_GP = 2*IF_UV_G+IF_SCALARS_G - -! Consistency checks - -IF (IF_UV > 0) THEN - IF(.NOT. PRESENT(PSPVOR) ) THEN - CALL ABORT_TRANS('DIR_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING') - ENDIF - IF(UBOUND(PSPVOR,1) < IF_UV) THEN - WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& - & UBOUND(PSPVOR,1),IF_UV - CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR TOO SHORT') - ENDIF - IF(.NOT. PRESENT(PSPDIV) ) THEN - CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR PRESENT BUT PSPDIV MISSING') - ENDIF - IF(UBOUND(PSPDIV,1) /= IF_UV) THEN - WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& - & UBOUND(PSPDIV,1),IF_UV - CALL ABORT_TRANS('DIR_TRANSAD : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') - ENDIF -ENDIF - -IF (IF_SCALARS > 0) THEN - IF(PRESENT(PSPSCALAR)) THEN - IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN - WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& - & UBOUND(PSPSCALAR,1),IF_SCALARS - CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR TOO SHORT') - ENDIF - IF(PRESENT(PSPSC3A))THEN - CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR AND PSPSC3A BOTH PRESENT') - ENDIF - IF(PRESENT(PSPSC3B))THEN - CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR AND PSPSC3B BOTH PRESENT') - ENDIF - IF(PRESENT(PSPSC2))THEN - CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR AND PSPSC2 BOTH PRESENT') - ENDIF - ENDIF -ENDIF - -IF(NPRTRV >1) THEN - IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN - WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& - &NPRTRV,IF_UV - CALL ABORT_TRANS('DIR_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& - &NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& - &NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& - &NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& - &NPRTRV - CALL ABORT_TRANS('DIR_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF -ENDIF - -IF(PRESENT(PGP)) THEN - IUBOUND(1:3)=UBOUND(PGP) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') - ENDIF - IF(IUBOUND(2) < IF_GP) THEN - WRITE(NOUT,*)'DIR_TRANSAD:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP - CALL ABORT_TRANS('DIR_TRANSAD:SECOND DIMENSION OF PGP TOO SMALL ') - ENDIF - IF(IUBOUND(3) < NGPBLKS) THEN - WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS - CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP TOO SMALL ') - ENDIF -ENDIF - -IF(PRESENT(PGPUV)) THEN - IF(.NOT.PRESENT(PSPVOR)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') - ENDIF - IUBOUND=UBOUND(PGPUV) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_UV_G) THEN - WRITE(NOUT,*)'DIR_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G - CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') - ENDIF - IF(IUBOUND(3) < 2) THEN - WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 - CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') - ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('DIR_TRANSAD:FOURTH DIMENSION OF PGPUV TOO SMALL ') - ENDIF -ENDIF - -IF(PRESENT(PGP2)) THEN - IF(.NOT.PRESENT(PSPSC2)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') - ENDIF -ENDIF -IF(IF_SC2_G > 0) THEN - IF(PRESENT(PGP2)) THEN - IUBOUND(1:3)=UBOUND(PGP2) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP2 TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_SC2_G) THEN - WRITE(NOUT,*)'DIR_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G - CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') - ENDIF - IF(IUBOUND(3) < NGPBLKS) THEN - WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS - CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') - ENDIF - ELSE - CALL ABORT_TRANS('DIR_TRANSAD:PGP2 MISSING') - ENDIF -ENDIF - -IF(PRESENT(PGP3A)) THEN - IF(.NOT.PRESENT(PSPSC3A)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') - ENDIF -ENDIF -IF(IF_SC3A_G > 0) THEN - IF(PRESENT(PGP3A)) THEN - IUBOUND=UBOUND(PGP3A) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_SC3A_G) THEN - WRITE(NOUT,*)'DIR_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G - CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') - ENDIF - IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN - WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& - & IUBOUND(3),UBOUND(PSPSC3A,3) - CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') - ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('DIR_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') - ENDIF - ELSE - CALL ABORT_TRANS('DIR_TRANSAD:PGP3A MISSING') - ENDIF -ENDIF - -IF(PRESENT(PGP3B)) THEN - IF(.NOT.PRESENT(PSPSC3B)) THEN - CALL ABORT_TRANS('DIR_TRANSAD:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') - ENDIF -ENDIF -IF(IF_SC3B_G > 0) THEN - IF(PRESENT(PGP3B)) THEN - IUBOUND=UBOUND(PGP3B) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_SC3B_G) THEN - WRITE(NOUT,*)'DIR_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G - CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') - ENDIF - IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN - WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& - & IUBOUND(3),UBOUND(PSPSC3B,3) - CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') - ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'DIR_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('DIR_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') - ENDIF - ELSE - CALL ABORT_TRANS('DIR_TRANSAD:PGP3B MISSING') - ENDIF -ENDIF -CALL GSTATS(1810,1) - -! Perform transform - -CALL DIR_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& - & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& - & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) - -IF (LHOOK) CALL DR_HOOK('DIR_TRANSAD',1,ZHOOK_HANDLE) - -! ------------------------------------------------------------------ -!endif INTERFACE - -END SUBROUTINE DIR_TRANSAD - - diff --git a/src/trans/gpu/external/gpnorm_trans.F90 b/src/trans/gpu/external/gpnorm_trans.F90 index 3f92ba0d2..18dff4e99 100755 --- a/src/trans/gpu/external/gpnorm_trans.F90 +++ b/src/trans/gpu/external/gpnorm_trans.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2008- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -56,16 +57,18 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) USE TPM_GEN ,ONLY : NOUT USE TPM_DIM ,ONLY : R -USE TPM_TRANS ,ONLY : LGPNORM, NGPBLKS, NPROMA, ZGTF, ZAVE, ZMINGL, ZMAXGL, ZMINGPN, ZMAXGPN +USE TPM_TRANS ,ONLY : LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW, NPROC, D_NSTAGTF,D_NPTRLS, MYPROC -USE TPM_GEOMETRY ,ONLY : G,G_NLOEN,G_NLOEN_MAX +USE TPM_GEOMETRY ,ONLY : G,G_NLOEN USE TPM_FIELDS ,ONLY : F USE SET_RESOL_MOD ,ONLY : SET_RESOL -USE TRGTOL_MOD ,ONLY : TRGTOL USE SET2PE_MOD ,ONLY : SET2PE USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE TRGTOL_MOD +USE TPM_TRANS, ONLY:REUSE_PTR +USE ALLOCATOR_MOD !endif INTERFACE @@ -91,12 +94,13 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) !GPU -!REAL(KIND=JPRBT),ALLOCATABLE :: ZGTF(:,:) -!REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) -!REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGL(:,:) -!REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGL(:,:) -!REAL(KIND=JPRBT),ALLOCATABLE :: ZMIN(:) -!REAL(KIND=JPRBT),ALLOCATABLE :: ZMAX(:) +REAL(KIND=JPRBT) :: V +REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:) +REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) +REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGL(:,:) +REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGL(:,:) +REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGPN(:) +REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGPN(:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMING(:) REAL(KIND=JPRB),ALLOCATABLE :: ZMAXG(:) @@ -104,8 +108,11 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS,JMAX INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND +TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR +TYPE(TRGTOL_HANDLE) :: HTRGTOL !INTEGER(KIND=JPIM) :: iunit + ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',0,ZHOOK_HANDLE) @@ -135,7 +142,7 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) IF_GP=KFIELDS -IF_SCALARS_G=0 +IF_SCALARS_G=KFIELDS IF_FS=0 DO J=1,KFIELDS @@ -144,6 +151,18 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) IF_FS=IF_FS+1 ENDIF ENDDO +ALLOCATE(ZAVE(IF_FS,R%NDGL)) +ALLOCATE(ZMINGL(IF_FS,R%NDGL)) +ALLOCATE(ZMAXGL(IF_FS,R%NDGL)) +ALLOCATE(ZMINGPN(IF_FS)) +ALLOCATE(ZMAXGPN(IF_FS)) + +ZAVE = 0._JPRBT +ZMINGL = 0._JPRBT +ZMAXGL = 0._JPRBT +ZMINGPN = 0._JPRBT +ZMAXGPN = 0._JPRBT +!$ACC DATA COPY(ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 @@ -164,43 +183,46 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) ! write(iunit,*) 'PGP field=',JF,PGP(1,JF,1),PGP(NPROMA,JF,1),PGP(1,JF,NGPBLKS) !ENDDO -! done in setup_trans +ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() +HTRGTOL = PREPARE_TRGTOL(ALLOCATOR,IF_GP,IF_FS) +CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, REUSE_PTR) + LGPNORM=.TRUE. -CALL TRGTOL(ZGTF,IF_FS,IF_GP,IF_SCALARS_G,IVSET,PGP=PGP) +CALL TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,IF_FS,IF_GP,0,IF_SCALARS_G,& + & KVSETSC=IVSET,PGP=PGP) LGPNORM=.FALSE. -! ZGTF is now on GPU - IBEG=1 IEND=D%NDGL_FS CALL GSTATS(1429,0) IF( IF_FS > 0 )THEN - !$ACC data & - !$ACC& COPY(F,F%RW) & - !$ACC& COPY(D,D_NSTAGTF,D_NPTRLS,G_NLOEN,G_NLOEN_MAX) & - !$ACC& present(ZGTF,ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) + !$ACC DATA & + !$ACC& PRESENT(F,F%RW) & + !$ACC& PRESENT(D,D_NSTAGTF,D_NPTRLS,G_NLOEN) !$ACC KERNELS DO JF=1,IF_FS - ZMINGL(JF,IBEG:IEND)=ZGTF(JF,D_NSTAGTF(1)+1) - ZMAXGL(JF,IBEG:IEND)=ZGTF(JF,D_NSTAGTF(1)+1) + V = PREEL_REAL(IF_FS*D_NSTAGTF(1)+(JF-1)*(D%NSTAGTF(2)-D%NSTAGTF(1))) + ZMINGL(JF,IBEG:IEND)=HUGE(1_JPRBT) + ZMAXGL(JF,IBEG:IEND)=-HUGE(1_JPRBT) ENDDO !$ACC END KERNELS ! FIRST DO SUMS IN EACH FULL LATITUDE !$ACC KERNELS - DO JGL=IBEG,IEND + DO JGL=1,D%NDGL_FS IGL = D_NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=0.0_JPRB !$ACC loop DO JL=1,G_NLOEN(IGL) - ZAVE(JF,JGL)=ZAVE(JF,JGL)+ZGTF(JF,D_NSTAGTF(JGL)+JL) - ZMINGL(JF,JGL)=MIN(ZMINGL(JF,JGL),ZGTF(JF,D_NSTAGTF(JGL)+JL)) - ZMAXGL(JF,JGL)=MAX(ZMAXGL(JF,JGL),ZGTF(JF,D_NSTAGTF(JGL)+JL)) + V = PREEL_REAL(IF_FS*D%NSTAGTF(JGL)+(JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL))+JL) + ZAVE(JF,JGL)=ZAVE(JF,JGL)+V + ZMINGL(JF,JGL)=MIN(ZMINGL(JF,JGL),V) + ZMAXGL(JF,JGL)=MAX(ZMAXGL(JF,JGL),V) ENDDO ENDDO ENDDO @@ -225,20 +247,8 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !$ACC end data -!$ACC update host(ZAVE) -!$ACC update host(ZMINGPN) -!$ACC update host(ZMAXGPN) -!$ACC wait - -!iunit=300+myproc -!DO JGL=IBEG,IEND -! IGL = D_NPTRLS(MYSETW) + JGL - 1 -! DO JF=1,IF_FS -! write(iunit,*) 'aver final ',JF,IF_FS,IGL,ZAVE(JF,JGL),ZMINGPN(JF),ZMAXGPN(JF) -! ENDDO -!ENDDO - ENDIF +!$ACC end data CALL GSTATS(1429,1) ! from here rest on CPU @@ -456,10 +466,6 @@ SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) ENDIF -!DEALLOCATE(ZGTF) -!DEALLOCATE(ZAVE) -!DEALLOCATE(ZMIN) -!DEALLOCATE(ZMAX) DEALLOCATE(ZAVEG) DEALLOCATE(ZMING) DEALLOCATE(ZMAXG) diff --git a/src/trans/gpu/external/inv_trans.F90 b/src/trans/gpu/external/inv_trans.F90 index 5e7b025a1..8c46bc391 100755 --- a/src/trans/gpu/external/inv_trans.F90 +++ b/src/trans/gpu/external/inv_trans.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -131,7 +132,6 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA -USE TPM_FIELDS ,ONLY : IF_FS_INV,IF_FS_INV0,ITDZBA,ITDZBS,ITDZCA,ITDZCS USE TPM_FLT, ONLY: S USE TPM_GEOMETRY ,ONLY : G !USE TPM_GEOMETRY @@ -142,6 +142,9 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& USE INV_TRANS_CTL_MOD ,ONLY : INV_TRANS_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK +USE MPL_MODULE ,ONLY : MPL_BARRIER +USE TPM_GEN ,ONLY : LSYNC_TRANS +USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX #ifdef _OPENACC use openacc @@ -196,7 +199,10 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& call flush(unit_no) IF (LHOOK) CALL DR_HOOK('INV_TRANS',0,ZHOOK_HANDLE) -CALL GSTATS(441,0) +IF (LSYNC_TRANS) THEN + CALL MPL_BARRIER(CDSTRING='') +ENDIF +CALL GSTATS(420,0) CALL GSTATS(1807,0) ! Set current resolution CALL SET_RESOL(KRESOL) @@ -366,8 +372,6 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& ! Compute derived variables -IF(LVORGP) LDIVGP = .TRUE. - NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS @@ -382,12 +386,6 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& IF(IF_UV > 0 .AND. LUVDER) THEN IF_FS = IF_FS+2*IF_UV ENDIF -! importance related to cuFFT -D%IADJUST_I=0 -!IF(MOD(IF_FS,2)==1) THEN -! IF_FS = IF_FS + 1 -! D%IADJUST_I=1 -!ENDIF IF_GP = 2*IF_UV_G+IF_SCALARS_G IF(LSCDERS) THEN @@ -409,33 +407,22 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& IF_UV_PAR = IF_UV_PAR+2 ENDIF -! set currently used array sizes for the GPU arrays: -!IF_FS_INV= 8*IF_UV + 2*IF_SCALARS + 2*IF_SCDERS -!Andreas: we were using the previous line in setup_trans but this doesn't consider derivatives. Better: -IF_FS_INV=2*IF_OUT_LT -print*,"inv_trans: IF_FS_INV=",IF_FS_INV," IF_FS_INV0=",IF_FS_INV0 - -ITDZBA=IF_FS_INV -ITDZBS=IF_FS_INV -ITDZCA=IF_FS_INV -ITDZCS=IF_FS_INV - ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF - IF(UBOUND(PSPVOR,1) < IF_UV) THEN - WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV - CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT') + IF(UBOUND(PSPVOR,1) /= IF_UV) THEN + WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) /= IF_UV ',UBOUND(PSPVOR,1),IF_UV + CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT OR TOO LONG') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPDIV MISSING') ENDIF - IF(UBOUND(PSPDIV,1) < IF_UV) THEN - WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV - CALL ABORT_TRANS('INV_TRANS : PSPDIV TOO SHORT') + IF(UBOUND(PSPDIV,1) /= IF_UV) THEN + WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) /= IF_UV ',UBOUND(PSPDIV,1),IF_UV + CALL ABORT_TRANS('INV_TRANS : PSPDIV TOO SHORT OR TOO LONG') ENDIF ENDIF @@ -450,10 +437,10 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF - IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN - WRITE(NERR,*)'INV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& + IF(UBOUND(PSPSCALAR,1) /= IF_SCALARS) THEN + WRITE(NERR,*)'INV_TRANS : UBOUND(PSPSCALAR,1) /= IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS - CALL ABORT_TRANS('INV_TRANS : PSPSCALAR TOO SHORT') + CALL ABORT_TRANS('INV_TRANS : PSPSCALAR TOO SHORT OR TOO LONG') ENDIF ELSEIF(PRESENT(PSPSC3A)) THEN ENDIF @@ -505,19 +492,19 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& CALL ABORT_TRANS('INV_TRANS:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') + IF(IUBOUND(1) /= NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL/LARGE ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL/LARGE ') ENDIF - IF(IUBOUND(2) < IF_GP) THEN - WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP + IF(IUBOUND(2) /= IF_GP) THEN + WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP TOO SMALL/LARGE ',IUBOUND(2),IF_GP WRITE(NOUT,*)'IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER ',& & IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER - CALL ABORT_TRANS('INV_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') + CALL ABORT_TRANS('INV_TRANS:SECOND DIMENSION OF PGP TOO SMALL/LARGE ') ENDIF - IF(IUBOUND(3) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS - CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') + IF(IUBOUND(3) /= NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL/LARGE ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP TOO SMALL/LARGE ') ENDIF ELSE IF(NPROMATR > 0 .AND. 2*IF_UV_G+IF_SCALARS_G > NPROMATR) THEN @@ -530,21 +517,21 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& CALL ABORT_TRANS('INV_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') + IF(IUBOUND(1) /= NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF - IF(IUBOUND(3) < IF_UV_PAR) THEN - WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR - CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') + IF(IUBOUND(3) /= IF_UV_PAR) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(3),IF_UV_PAR + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') + IF(IUBOUND(4) /= NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN @@ -555,17 +542,17 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& IF(IF_SC2_G > 0) THEN IF(PRESENT(PGP2)) THEN IUBOUND(1:3)=UBOUND(PGP2) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') + IF(IUBOUND(1) /= NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP2 TOO SMALL/LARGE ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF - IF(IUBOUND(3) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS - CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') + IF(IUBOUND(3) /= NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL/LARGE ',IUBOUND(3),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP2 MISSING') @@ -580,9 +567,9 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& IF(IF_SC3A_G3 > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') + IF(IUBOUND(1) /= NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3A TOO SMALL/LARGE ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 @@ -593,9 +580,9 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') + IF(IUBOUND(4) /= NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL/LARGE ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3A MISSING') @@ -610,9 +597,9 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& IF(IF_SC3B_G3 > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') + IF(IUBOUND(1) /= NPROMA) THEN + WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3B TOO SMALL/LARGE ',IUBOUND(1),NPROMA + CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 @@ -623,9 +610,9 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') + IF(IUBOUND(4) /= NGPBLKS) THEN + WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3B TOO SMALL/LARGE ',IUBOUND(4),NGPBLKS + CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3B MISSING') @@ -643,7 +630,12 @@ SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LHOOK) CALL DR_HOOK('INV_TRANS',1,ZHOOK_HANDLE) -CALL GSTATS(441,1) +IF (LSYNC_TRANS) THEN + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) +ENDIF +CALL GSTATS(420,1) ! ------------------------------------------------------------------ !endif INTERFACE diff --git a/src/trans/gpu/external/inv_transad.F90 b/src/trans/gpu/external/inv_transad.F90 deleted file mode 100755 index f4ad3d0fd..000000000 --- a/src/trans/gpu/external/inv_transad.F90 +++ /dev/null @@ -1,618 +0,0 @@ -! (C) Copyright 2000- 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 INV_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& - & FSPGL_PROC,& - & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& - & KVSETSC3A,KVSETSC3B,KVSETSC2,& - & PGP,PGPUV,PGP3A,PGP3B,PGP2) - -!**** *INV_TRANSAD* - Inverse spectral transform - adjoint. - -! Purpose. -! -------- -! Interface routine for the inverse spectral transform - adjoint - -!** Interface. -! ---------- -! CALL INV_TRANSAD(...) - -! Explicit arguments : All arguments except from PGP are optional. -! -------------------- -! PSPVOR(:,:) - spectral vorticity (input) -! PSPDIV(:,:) - spectral divergence (input) -! PSPSCALAR(:,:) - spectral scalarvalued fields (input) -! PSPSC3A(:,:,:) - alternative to use of PSPSCALAR, see PGP3A below (input) -! PSPSC3B(:,:,:) - alternative to use of PSPSCALAR, see PGP3B below (input) -! PSPSC2(:,:) - alternative to use of PSPSCALAR, see PGP2 below (input) -! FSPGL_PROC - external procedure to be executed in fourier space -! before transposition -! LDSCDERS - indicating if derivatives of scalar variables are req. -! LDVORGP - indicating if grid-point vorticity is req. -! LDDIVGP - indicating if grid-point divergence is req. -! LDUVDER - indicating if E-W derivatives of u and v are req. -! KPROMA - required blocking factor for gridpoint output -! KVSETUV(:) - indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. -! KVESETSC(:) - indicating which 'b-set' in spectral space owns a -! scalar field. As for KVSETUV this argument is required -! if the total number of processors is greater than -! the number of processors used for distribution in -! spectral wave space. -! KVSETSC3A(:) - as KVESETSC for PSPSC3A (distribution on first dimension) -! KVSETSC3B(:) - as KVESETSC for PSPSC3B (distribution on first dimension) -! KVSETSC2(:) - as KVESETSC for PSPSC2 (distribution on first dimension) -! KRESOL - resolution tag which is required ,default is the -! first defined resulution (input) -! PGP(:,:,:) - gridpoint fields (output) -! PGP need to dimensioned (NPROMA,IF_GP,NGPBLKS) where -! NPROMA is the blocking factor, IF_GP the total number -! of output fields and NGPBLKS the number of NPROMA blocks. -! The ordering of the output fields is as follows (all -! parts are optional depending on the input switches): -! -! vorticity : IF_UV_G fields (if psvor present and LDVORGP) -! divergence : IF_UV_G fields (if psvor present and LDDIVGP) -! u : IF_UV_G fields (if psvor present) -! v : IF_UV_G fields (if psvor present) -! scalar fields : IF_SCALARS_G fields (if pspscalar present) -! N-S derivative of scalar fields : IF_SCALARS_G fields (if pspscalar -! present and LDSCDERS) -! E-W derivative of u : IF_UV_G fields (if psvor present and and LDUVDER) -! E-W derivative of v : IF_UV_G fields (if psvor present and and LDUVDER) -! E-W derivative of scalar fields : IF_SCALARS_G fields (if pspscalar -! present and LDSCDERS) -! -! Here IF_UV_G is the GLOBAL number of u/v fields as given by the length -! of KVSETUV (or by PSPVOR if no split in spectral 'b-set' direction -! IF_SCALARS_G is the GLOBAL number of scalar fields as giben by the -! length of KVESETSC (or by number of fields in PSPSCALAR if no spectral -! 'b-set' split - -! As an alternative to using PGP you can also use a combination of the -! following arrays. The reason for introducing these alternative ways -! of calling INV_TRANS is to avoid uneccessary copies where your data -! structures don't fit in to the 'PSPVOR,PSPDIV, PSPSCALAR, PGP' layout. -! The use of any of these precludes the use of PGP and vice versa. -! -! PGPUV(:,:,:,:) - the 'u-v' related grid-point variables in the order -! described for PGP. The second dimension of PGPUV should -! be the same as the "global" first dimension of -! PSPVOR,PSPDIV (in the IFS this is the number of levels) -! PGPUV need to be dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (u,v,vor,div ...) -! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A -! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (the same as in -! PSPSC3A if no derivatives, 3 times that with der.) -! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B -! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (the same as in -! PSPSC3B if no derivatives, 3 times that with der.) -! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 -! dimensioned(NPROMA,IFLDS,NGPBLKS) -! IFLDS is the number of 'variables' (the same as in -! PSPSC2 if no derivatives, 3 times that with der.) - -! Method. -! ------- - -! Externals. SET_RESOL - set resolution -! ---------- LTDIR_CTLAD - control of Legendre transform -! FTDIR_CTLAD - control of Fourier transform - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 - -! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -!ifndef INTERFACE - -USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR -!USE TPM_DIM -USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & - & NF_SC2, NF_SC3A, NF_SC3B, & - & NGPBLKS, NPROMA -USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV -!USE TPM_GEOMETRY -!USE TPM_FIELDS -!USE TPM_FFT - -USE SET_RESOL_MOD ,ONLY : SET_RESOL -USE INV_TRANS_CTLAD_MOD ,ONLY : INV_TRANS_CTLAD -USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -!endif INTERFACE - -IMPLICIT NONE - -! Declaration of arguments - -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) -LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS -LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP -LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP -LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL -EXTERNAL FSPGL_PROC -OPTIONAL FSPGL_PROC -REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP(:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PGP2(:,:,:) - -!ifndef INTERFACE - -! Local varaibles -INTEGER(KIND=JPIM) :: IUBOUND(4),J -INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP,IF_OUT_LT -INTEGER(KIND=JPIM) :: IF_SCDERS,IF_UV_PAR -INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G2,IF_SC3A_G3,IF_SC3B_G2,IF_SC3B_G3 -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -! ------------------------------------------------------------------ - -IF (LHOOK) CALL DR_HOOK('INV_TRANSAD',0,ZHOOK_HANDLE) -CALL GSTATS(1809,0) -! Set current resolution -CALL SET_RESOL(KRESOL) - -! Set defaults - -LVORGP = .FALSE. -LDIVGP = .FALSE. -LUVDER = .FALSE. -IF_UV = 0 -IF_UV_G = 0 -IF_UV_PAR = 0 -IF_SCALARS = 0 -IF_SCALARS_G = 0 -IF_SCDERS = 0 -NF_SC2 = 0 -NF_SC3A = 0 -NF_SC3B = 0 -IF_SC2_G = 0 -IF_SC3A_G2 = 0 -IF_SC3B_G2 = 0 -IF_SC3A_G3 = 0 -IF_SC3B_G3 = 0 -NPROMA = D%NGPTOT -LSCDERS = .FALSE. - -! Decide requirements - -IF(PRESENT(KVSETUV)) THEN - IF_UV_G = UBOUND(KVSETUV,1) - IF_UV_PAR = 2 - DO J=1,IF_UV_G - IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN - WRITE(NERR,*) 'INV_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV - CALL ABORT_TRANS('INV_TRANSAD:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETUV(J) == MYSETV) THEN - IF_UV = IF_UV+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPVOR)) THEN - IF_UV = UBOUND(PSPVOR,1) - IF_UV_G = IF_UV - IF_UV_PAR = 2 -ENDIF - -IF(PRESENT(KVSETSC)) THEN - IF_SCALARS_G = UBOUND(KVSETSC,1) - DO J=1,IF_SCALARS_G - IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN - WRITE(NERR,*) 'INV_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV - CALL ABORT_TRANS('INV_TRANSAD:KVSETSC TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSCALAR)) THEN - IF_SCALARS = UBOUND(PSPSCALAR,1) - IF_SCALARS_G = IF_SCALARS -ENDIF - -IF(PRESENT(KVSETSC2)) THEN - IF(.NOT.PRESENT(PSPSC2)) THEN - CALL ABORT_TRANS('INV_TRANSAD:KVSETSC2 BUT NOT PSPSC2') - ENDIF - IF_SC2_G = UBOUND(KVSETSC2,1) - IF_SCALARS_G = IF_SCALARS_G+UBOUND(KVSETSC2,1) - DO J=1,UBOUND(KVSETSC2,1) - IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN - WRITE(NERR,*) 'INV_TRANSAD:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV - CALL ABORT_TRANS('INV_TRANSAD:KVSETSC2 TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC2(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+1 - NF_SC2 = NF_SC2+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSC2)) THEN - IF_SC2_G = UBOUND(PSPSC2,1) - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC2,1) - IF_SCALARS_G = IF_SCALARS_G +UBOUND(PSPSC2,1) - NF_SC2 = UBOUND(PSPSC2,1) -ENDIF - -IF(PRESENT(KVSETSC3A)) THEN - IF(.NOT.PRESENT(PSPSC3A)) THEN - CALL ABORT_TRANS('INV_TRANSAD:KVSETSC3A BUT NOT PSPSC3A') - ENDIF - IF_SC3A_G2 = UBOUND(KVSETSC3A,1) - IF_SC3A_G3 = UBOUND(PSPSC3A,3) - IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G2*IF_SC3A_G3 - DO J=1,UBOUND(KVSETSC3A,1) - IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN - WRITE(NERR,*) 'INV_TRANSAD:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV - CALL ABORT_TRANS& - &('INV_TRANSAD:KVSETSC3A TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC3A(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,3) - NF_SC3A = NF_SC3A+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSC3A)) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3A,1)*UBOUND(PSPSC3A,3) - IF_SC3A_G2 = UBOUND(PSPSC3A,1) - IF_SC3A_G3 = UBOUND(PSPSC3A,3) - IF_SCALARS_G = IF_SCALARS_G + IF_SC3A_G2*IF_SC3A_G3 - NF_SC3A = UBOUND(PSPSC3A,1) -ENDIF - -IF(PRESENT(KVSETSC3B)) THEN - IF(.NOT.PRESENT(PSPSC3B)) THEN - CALL ABORT_TRANS('INV_TRANSAD:KVSETSC3B BUT NOT PSPSC3B') - ENDIF - IF_SC3B_G2 = UBOUND(KVSETSC3B,1) - IF_SC3B_G3 = UBOUND(PSPSC3B,3) - IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G2*IF_SC3B_G3 - DO J=1,UBOUND(KVSETSC3B,1) - IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN - WRITE(NERR,*) 'INV_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV - CALL ABORT_TRANS('INV_TRANSAD:KVSETSC3B TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETSC3B(J) == MYSETV) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,3) - NF_SC3B = NF_SC3B+1 - ENDIF - ENDDO -ELSEIF(PRESENT(PSPSC3B)) THEN - IF_SCALARS = IF_SCALARS+UBOUND(PSPSC3B,1)*UBOUND(PSPSC3B,3) - IF_SC3B_G2 = UBOUND(PSPSC3B,1) - IF_SC3B_G3 = UBOUND(PSPSC3B,3) - IF_SCALARS_G = IF_SCALARS_G + IF_SC3B_G2*IF_SC3B_G3 - NF_SC3B = UBOUND(PSPSC3B,1) -ENDIF - - -IF (IF_SCALARS > 0) THEN - IF(PRESENT(LDSCDERS)) THEN - LSCDERS = LDSCDERS - IF (LSCDERS) IF_SCDERS = IF_SCALARS - ENDIF -ENDIF - -IF(PRESENT(KPROMA)) THEN - NPROMA = KPROMA -ENDIF - -IF(PRESENT(LDVORGP)) THEN - LVORGP = LDVORGP -ENDIF - -IF(PRESENT(LDDIVGP)) THEN - LDIVGP = LDDIVGP -ENDIF - -IF(PRESENT(LDUVDER)) THEN - LUVDER = LDUVDER -ENDIF - - - -! Compute derived variables - - -IF(LVORGP) LDIVGP = .TRUE. - -NGPBLKS = (D%NGPTOT-1)/NPROMA+1 - -IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS - -IF(IF_UV > 0 .AND. LVORGP) THEN - IF_OUT_LT = IF_OUT_LT+IF_UV -ENDIF -IF(IF_UV > 0 .AND. LDIVGP) THEN - IF_OUT_LT = IF_OUT_LT+IF_UV -ENDIF -IF_FS = IF_OUT_LT+IF_SCDERS -IF(IF_UV > 0 .AND. LUVDER) THEN - IF_FS = IF_FS+2*IF_UV -ENDIF - -IF_GP = 2*IF_UV_G+IF_SCALARS_G -IF(LSCDERS) THEN - IF_GP = IF_GP+2*IF_SCALARS_G - IF_SC2_G = IF_SC2_G*3 - IF_SC3A_G3 = IF_SC3A_G3*3 - IF_SC3B_G3 = IF_SC3B_G3*3 -ENDIF -IF(IF_UV_G > 0 .AND. LVORGP) THEN - IF_GP = IF_GP+IF_UV_G - IF_UV_PAR = IF_UV_PAR+1 -ENDIF -IF(IF_UV_G > 0 .AND. LDIVGP) THEN - IF_GP = IF_GP+IF_UV_G - IF_UV_PAR = IF_UV_PAR+1 -ENDIF -IF(IF_UV_G > 0 .AND. LUVDER) THEN - IF_GP = IF_GP+2*IF_UV_G - IF_UV_PAR = IF_UV_PAR+2 -ENDIF - -! Consistency checks - -IF (IF_UV > 0) THEN - IF(.NOT. PRESENT(PSPVOR) ) THEN - CALL ABORT_TRANS("INV_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING") - ENDIF - IF(UBOUND(PSPVOR,1) < IF_UV) THEN - WRITE(NERR,*)'INV_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& - & UBOUND(PSPVOR,1),IF_UV - CALL ABORT_TRANS("INV_TRANSAD : PSPVOR TOO SHORT") - ENDIF - IF(.NOT. PRESENT(PSPDIV) ) THEN - CALL ABORT_TRANS("INV_TRANSAD : IF_UV > 0 BUT PSPDIV MISSING") - ENDIF - IF(UBOUND(PSPDIV,1) < IF_UV) THEN - WRITE(NERR,*)'INV_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& - & UBOUND(PSPDIV,1),IF_UV - CALL ABORT_TRANS("INV_TRANSAD : PSPDIV TOO SHORT") - ENDIF -ENDIF - -IF (IF_SCALARS > 0) THEN - IF(PRESENT(PSPSCALAR)) THEN - IF(PRESENT(PSPSC3A))THEN - CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') - ENDIF - IF(PRESENT(PSPSC3B))THEN - CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') - ENDIF - IF(PRESENT(PSPSC2))THEN - CALL ABORT_TRANS('INV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') - ENDIF - IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN - WRITE(NERR,*)'INV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& - & UBOUND(PSPSCALAR,1),IF_SCALARS - CALL ABORT_TRANS('INV_TRANS : PSPSCALAR TOO SHORT') - ENDIF - ELSEIF(PRESENT(PSPSC3A)) THEN - ENDIF -ENDIF - -IF(IF_UV_G == 0) THEN - LUVDER = .FALSE. -ENDIF - -IF(NPRTRV >1) THEN - IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN - WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& - &NPRTRV,IF_UV - CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSCALAR) .AND. .NOT. PRESENT(KVSETSC)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSCALAR) AND NOT PRESENT(KVSETSC)',& - &NPRTRV - CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSC2) .AND. .NOT. PRESENT(KVSETSC2)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC2) AND NOT PRESENT(KVSETSC2)',& - &NPRTRV - CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSC3A) .AND. .NOT. PRESENT(KVSETSC3A)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3A) AND NOT PRESENT(KVSETSC3A)',& - &NPRTRV - CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF - IF(PRESENT(PSPSC3B) .AND. .NOT. PRESENT(KVSETSC3B)) THEN - WRITE(NERR,*)'NPRTRV >1 AND PRESENT(PSPSC3B) AND NOT PRESENT(KVSETSC3B)',& - &NPRTRV - CALL ABORT_TRANS('INV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF -ENDIF - -IF(PRESENT(PGP)) THEN - IF(PRESENT(PGPUV)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGPUV CAN NOT BOTH BE PRESENT') - ENDIF - IF(PRESENT(PGP3A)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGP3A CAN NOT BOTH BE PRESENT') - ENDIF - IF(PRESENT(PGP3B)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGP3B CAN NOT BOTH BE PRESENT') - ENDIF - IF(PRESENT(PGP2)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PGP AND PGP2 CAN NOT BOTH BE PRESENT') - ENDIF - IUBOUND(1:3)=UBOUND(PGP) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') - ENDIF - IF(IUBOUND(2) < IF_GP) THEN - WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP - WRITE(NOUT,*)'IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER ',& - & IF_UV_G,IF_SCALARS_G,LSCDERS,LVORGP,LDIVGP,LUVDER - CALL ABORT_TRANS('INV_TRANSAD:SECOND DIMENSION OF PGP TOO SMALL ') - ENDIF - IF(IUBOUND(3) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS - CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP TOO SMALL ') - ENDIF -ELSE - IF(NPROMATR > 0 .AND. 2*IF_UV_G+IF_SCALARS_G > NPROMATR) THEN - CALL ABORT_TRANS('INV_TRANSAD:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') - ENDIF -ENDIF - -IF(PRESENT(PGPUV)) THEN - IF(.NOT.PRESENT(PSPVOR)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') - ENDIF - IUBOUND(1:4)=UBOUND(PGPUV) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_UV_G) THEN - WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G - CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') - ENDIF - IF(IUBOUND(3) < IF_UV_PAR) THEN - WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR - CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') - ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') - ENDIF -ENDIF - -IF(PRESENT(PGP2)) THEN - IF(.NOT.PRESENT(PSPSC2)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PSPSC2 HAS TO BE PRESENT WHEN PGP2 IS') - ENDIF -ENDIF -IF(IF_SC2_G > 0) THEN - IF(PRESENT(PGP2)) THEN - IUBOUND(1:3)=UBOUND(PGP2) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP2 TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_SC2_G) THEN - WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G - CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') - ENDIF - IF(IUBOUND(3) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS - CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') - ENDIF - ELSE - CALL ABORT_TRANS('INV_TRANSAD:PGP2 MISSING') - ENDIF -ENDIF - -IF(PRESENT(PGP3A)) THEN - IF(.NOT.PRESENT(PSPSC3A)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') - ENDIF -ENDIF -IF(IF_SC3A_G3 > 0) THEN - IF(PRESENT(PGP3A)) THEN - IUBOUND=UBOUND(PGP3A) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_SC3A_G2) THEN - WRITE(NOUT,*)'INV_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 - CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') - ENDIF - IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN - WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& - & IUBOUND(3),IF_SC3A_G3 - CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') - ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('INV_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') - ENDIF - ELSE - CALL ABORT_TRANS('INV_TRANSAD:PGP3A MISSING') - ENDIF -ENDIF - -IF(PRESENT(PGP3B)) THEN - IF(.NOT.PRESENT(PSPSC3B)) THEN - CALL ABORT_TRANS('INV_TRANSAD:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') - ENDIF -ENDIF -IF(IF_SC3B_G3 > 0) THEN - IF(PRESENT(PGP3B)) THEN - IUBOUND=UBOUND(PGP3B) - IF(IUBOUND(1) < NPROMA) THEN - WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA - CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') - ENDIF - IF(IUBOUND(2) /= IF_SC3B_G2) THEN - WRITE(NOUT,*)'INV_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 - CALL ABORT_TRANS('INV_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') - ENDIF - IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN - WRITE(NOUT,*)'INV_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& - & IUBOUND(3),IF_SC3B_G3 - CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') - ENDIF - IF(IUBOUND(4) < NGPBLKS) THEN - WRITE(NOUT,*)'INV_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS - CALL ABORT_TRANS('INV_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') - ENDIF - ELSE - CALL ABORT_TRANS('INV_TRANSAD:PGP3B MISSING') - ENDIF -ENDIF -CALL GSTATS(1809,1) - -! ------------------------------------------------------------------ - -! Perform transform - -CALL INV_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_OUT_LT,& - & IF_UV,IF_SCALARS,IF_SCDERS,& - & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& - & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) - -IF (LHOOK) CALL DR_HOOK('INV_TRANSAD',1,ZHOOK_HANDLE) - -! ------------------------------------------------------------------ - -!endif INTERFACE - -END SUBROUTINE INV_TRANSAD - diff --git a/src/trans/gpu/external/setup_trans.F90 b/src/trans/gpu/external/setup_trans.F90 index cd5f8a43c..e64d8c5ae 100755 --- a/src/trans/gpu/external/setup_trans.F90 +++ b/src/trans/gpu/external/setup_trans.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -103,26 +105,19 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& USE TPM_GEN ,ONLY : NOUT, MSETUP0, NCUR_RESOL, NDEF_RESOL, & & NMAX_RESOL, NPRINTLEV, LENABLED, NERR -USE TPM_DIM ,ONLY : R, DIM_RESOL, R_NSMAX,R_NTMAX, R_NDGNH, R_NDGL, R_NNOEXTZL +USE TPM_DIM ,ONLY : R, DIM_RESOL, R_NSMAX,R_NTMAX, R_NDGNH, R_NDGL USE TPM_DISTR ,ONLY : D, DISTR_RESOL,NPROC,nprtrv, D_NUMP,D_MYMS,D_NSTAGT0B,D_NSTAGT1B,D_NPROCL,D_NPNTGTB1, D_NASM0, & -& D_NSTAGTF,D_MSTABF,D_NPNTGTB0,D_NPROCM,D_NPTRLS,mysetv,mysetw, MYPROC +& D_NSTAGTF,D_MSTABF,D_NPNTGTB0,D_NPROCM,D_NPTRLS,mysetv,mysetw, MYPROC,D_OFFSETS_GEMM1, D_OFFSETS_GEMM2 USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL, G_NDGLU, G_NMEN, G_NMEN_MAX,G_NLOEN, G_NLOEN_MAX -USE TPM_FIELDS ,ONLY : FIELDS_RESOL, F,F_RW, ZIA,ZEPSNM,ZSOA1,ZAOA1,ISTAN,ISTAS,ZAIA,ZOA1,ZOA2, & -& ZAA,ZAS,LDZAA,LDZAS,TDZAA,TDZAS,& -& IZBS,ILDZBA,ILDZBS,ITDZBA0,ITDZBS0,& -& IZCA,IZCS,IZCST,ILDZCA,ILDZCS,ITDZCA0,ITDZCS0,& -& DZBAT,DZBST,DLDZBA,DLDZBS,DTDZBA0,DTDZBS0,& -& DZCAT,DZCST,DLDZCA,DLDZCS,DTDZCA0,DTDZCS0,& -& IF_FS_INV0,IF_FS_DIR0,NFLEV0,ZAA0,DZBST0,DZCAT0,& -& ZAS0,DZCST0,KMLOC0 -! IZBA,IZCAT +USE TPM_FIELDS ,ONLY : FIELDS_RESOL, F,F_RW, ZEPSNM, & +& ZAA,ZAS,& +& ZAA0,& +& ZAS0,KMLOC0 USE TPM_FFT ,ONLY : T, FFT_RESOL #ifdef WITH_FFTW USE TPM_FFTW ,ONLY : TW, FFTW_RESOL #endif -USE TPM_FFTC ,ONLY : TC, FFTC_RESOL USE TPM_FLT -USE TPM_TRANS ,ONLY : FOUBUF_IN, FOUBUF, ZGTF, ZAVE, ZMINGL, ZMAXGL, ZMINGPN, ZMAXGPN USE TPM_CTL USE SET_RESOL_MOD ,ONLY : SET_RESOL @@ -135,11 +130,9 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE SHAREDMEM_MOD ,ONLY : SHAREDMEM_CREATE USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK -USE CUDA_DEVICE_MOD USE PREPSNM_MOD ,ONLY : PREPSNM -#ifdef _OPENACC -use openacc -#endif +USE CUDAFOR +USE OPENACC !endif INTERFACE @@ -173,10 +166,8 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& !ifndef INTERFACE ! Local variables -INTEGER(KIND=JPIM),PARAMETER :: IMAXFLD=240 INTEGER(KIND=JPIM) :: JGL,JRES,IDEF_RESOL -INTEGER(KIND=JPIM) :: NFLEVL, JMLOC, KM, ILA, ILS, KMLOC, KDGLU, JK, i, J, IF_FS, IF_OUT_LT, IF_UV, IF_SCALARS -INTEGER(KIND=JPIM) :: IPPNUM, IF_PP, IF_FOUBUF +INTEGER(KIND=JPIM) :: JMLOC, KM, ILA, ILS, KMLOC, KDGLU, JK, i, J LOGICAL :: LLP1,LLP2, LLSPSETUPONLY REAL(KIND=JPRD) :: ZTIME0,ZTIME1,ZTIME2 @@ -207,7 +198,6 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& #ifdef WITH_FFTW ALLOCATE(FFTW_RESOL(NMAX_RESOL)) #endif - ALLOCATE(FFTC_RESOL(NMAX_RESOL)) ALLOCATE(FLT_RESOL(NMAX_RESOL)) ALLOCATE(CTL_RESOL(NMAX_RESOL)) GEOM_RESOL(:)%LAM=.FALSE. @@ -448,405 +438,106 @@ SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& IF( .NOT.D%LGRIDONLY ) THEN -!allocating arrays for the GPU: -IF(PRESENT(KFLEV)) THEN - NFLEV0 = KFLEV -! NFLEVL = NFLEV0/NPRTRV -ELSE - NFLEV0 = ceiling(REAL(IMAXFLD)/NPRTRV) -ENDIF - -! need to get local rank to be able to set device (1GPU == 1 MPI-rank) -!ilocal_rank = 0 -!call GETENV("OMPI_COMM_WORLD_LOCAL_RANK",comm_local_rank) -!read(comm_local_rank,'(I2)') ilocal_rank - iunit=300+myproc #ifdef _OPENACC -!!idevtype=acc_device_nvidia idevtype=acc_get_device_type() inumdevs = acc_get_num_devices(idevtype) mygpu = mod(MYPROC-1,inumdevs) CALL acc_set_device_num(mygpu, idevtype) mygpu = acc_get_device_num(idevtype) -istat = cuda_GetDevice(idev) +istat = cudaGetDevice(idev) WRITE(iunit,*) '===now going to allocate GPU arrays on processor: ', myproc, ' device = ', mygpu, ' ',idev, ' of ', inumdevs #endif -!dimensions of matrices for Legendre Transforms for RAPS ? -!IF_OUT_LT = 5*NFLEV0+2 -!IF_FS = 6*NFLEV0+3 - -! add additional post-processing requirements -!IF_PP = 2*NFLEV0 -IF_PP = 0 - -! u/v + scalars 3d + scalars 2d -IF_UV = NFLEV0 -! SCALARS INCLUDING DERIVATIVES -IF_SCALARS = NFLEV0 + 2*NFLEV0 + 1 + 2 + IF_PP -IF_OUT_LT = 4*IF_UV+3*NFLEV0+3+IF_PP -!IF_OUT_LT = 4*IF_UV+3*NFLEV0+3 -!8*KF_UV+2*KF_SCALARS -!ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS -IF_FS_INV0=8*IF_UV+2*IF_SCALARS - -! fields in Fourier space for inv trans the same -!IF_FS=4*IF_UV+1*NFLEV0+2 -IF_FS=4*IF_UV+1*NFLEV0+2 -! for derivatives u/v add -!IF_FS=IFS_FS+2*(2*NFLEV0) -! for each 3d scalar derivative add -IF_FS=IF_FS+2*NFLEV0 ! temperature -! for each 2d scalar derivative add -IF_FS=IF_FS+2 ! sfc pressure -IF_FS=IF_FS+IF_PP - -! u/v + scalars for direct transforms -! plus postprocessing buffer -!ippnum=NFLEV0 -IF_FS_DIR0=2*(2*IF_UV+NFLEV0+2+IF_PP) -!QUESTION: Why do we have NFLEV0 here? (Andreas) - -! fields in Fourier space for dir trans -!IF_FS = 2*IF_UV + IF_SCALARS -! plus add 2*scalar_derivatives + add vorg/divg + 2*IF_UV for u/v zonal derivatives - -write(nout,*)'setup_trans: if_uv=',if_uv,' if_out_lt=',if_out_lt,' IF_FS_DIR0=',IF_FS_DIR0,'IF_FS_INV0= ',IF_FS_INV0 -IF(MOD(IF_FS,2)==1) IF_FS = IF_FS + 1 - -!leading and trailing dimensions of A for symmetric and antisymmetric cases -! (same for ltinv and ltdir) -LDZAA=R%NDGNH -LDZAS=R%NDGNH -TDZAA=(R%NTMAX+2)/2 -TDZAS=(R%NTMAX+3)/2 print*,'R%NTMAX=',R%NTMAX print*,'R%NSMAX=',R%NSMAX -!similarly for B (ltinv) -ILDZBA=(R%NSMAX+2)/2 -ILDZBS=(R%NSMAX+3)/2 -ITDZBA0=IF_FS_INV0 -ITDZBS0=IF_FS_INV0 - -!similarly for C (ltinv) -ILDZCA=R%NDGNH -ILDZCS=R%NDGNH -ITDZCA0=IF_FS_INV0 -ITDZCS0=IF_FS_INV0 - -!similarly for B (ltdir) -DLDZBA=R%NDGNH -DLDZBS=R%NDGNH -DTDZBA0=IF_FS_DIR0 -DTDZBS0=IF_FS_DIR0 - -!similarly for C (ltdir) -DLDZCA=(R%NTMAX+2)/2 -DLDZCS=(R%NTMAX+3)/2 -DTDZCA0=IF_FS_DIR0 -DTDZCS0=IF_FS_DIR0 - -! competition: NPRTRV ... larger == NUMP ... larger == NSMAX/NPRTRW -! setting NPRTRV=20 ... leads to 7GB ZAA since NUMP==55 - -!allocate matrices for matrix multiplications -!ALLOCATE(IZBA(IF_FS_INV0*TDZAA*D%NUMP)) -ALLOCATE(IZBS(IF_FS_INV0*TDZAS*D%NUMP)) -print*,"New: allocating IZBS as a 1D array!" -! just use IZBS -!IZBA=>IZBS(:,1:TDZAA,:) - -ALLOCATE(ZAA(R%NDGNH,TDZAA,D%NUMP)) -ALLOCATE(ZAS(R%NDGNH,TDZAS,D%NUMP)) - -! Allocate matrices for rescaling to allow half-precision Legendre transforms -!ALLOCATE(ZAMAX(IF_FS_INV0,D%NUMP)) -!ALLOCATE(ZSMAX(IF_FS_INV0,D%NUMP)) - -! transpose of C (for better memory access patterns) -!ALLOCATE(IZCAT(IF_FS_INV0,R%NDGNH,D%NUMP)) -ALLOCATE(IZCST(IF_FS_INV0*R%NDGNH*D%NUMP)) - -!ALLOCATE(DZBAT(IF_FS_DIR0,R%NDGNH,D%NUMP)) -ALLOCATE(DZBST(IF_FS_DIR0*R%NDGNH*D%NUMP)) - -! transpose of C (for better memory access patterns) -ALLOCATE(DZCAT(IF_FS_DIR0*TDZAA*D%NUMP)) -ALLOCATE(DZCST(IF_FS_DIR0*TDZAS*D%NUMP)) -DZCAT(:) = 0 -DZCST(:) = 0 -IZCST(:) = 0 -!DZCAT=>DZCST(:,1:TDZAA,:) -write(nout,*)'setup_trans: sizes1 NUMP=',D%NUMP -write(nout,*)'ZAS:',size(ZAS) -write(nout,*)'IZBS :',size(IZBS ) -write(nout,*)'IZCST:',size(IZCST) -write(nout,*)'DZBST:',size(DZBST) -write(nout,*)'DZCST:',size(DZCST) -write(nout,*)'DZCAT:',size(DZCAT) -!!!$ACC ENTER DATA CREATE(ZAA,ZAS,IZBA,IZBS,IZCAT,IZCST,DZBAT,DZBST,DZCAT,DZCST) -!$ACC ENTER DATA COPYIN(ZAA,ZAS,IZBS,IZCST,DZBST,DZCST,DZCAT) & -!$ACC& COPYIN(F,F%RN,F%RLAPIN,S,S%FA,S%ITHRESHOLD,S%LUSEFLT,D,D%NUMP,D%MYMS,R,R%NDGNH,R%NSMAX,G,G%NDGLU) & -!$ACC& copyin(D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,G%NMEN,D%NPROCM,D%NPTRLS,G,G%NLOEN,D%MSTABF) +!$ACC ENTER DATA & +!$ACC& COPYIN(F,F%RN,F%RLAPIN,D,D%MYMS,R,G,G%NDGLU) & +!$ACC& COPYIN(D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,G%NMEN,D%NPROCM,D%NPTRLS,G,D%MSTABF) ! Initialize A arrays -izbs = 0._JPRBT -!$acc update device(izbs) -dzbst = 0._JPRBT -!$acc update device(dzbst) +ALLOCATE(ZAA(ALIGN(R%NDGNH,8),ALIGN((R%NTMAX+2)/2,8),D%NUMP)) +ALLOCATE(ZAS(ALIGN(R%NDGNH,8),ALIGN((R%NTMAX+3)/2,8),D%NUMP)) -! zero arrays -!$ACC PARALLEL LOOP -DO JMLOC=1,D%NUMP - !$ACC loop - DO JK=1,TDZAA - !$ACC loop - DO J=1,LDZAA - ZAA(J,JK,JMLOC)=0._JPRBT - ENDDO - ENDDO -ENDDO - -!$ACC PARALLEL LOOP -DO JMLOC=1,D%NUMP - !$ACC loop - DO JK=1,TDZAS - !$ACC LOOP - DO J=1,LDZAS - ZAS(J,JK,JMLOC)=0._JPRBT - ENDDO - ENDDO -ENDDO - -! Do this on the host - -zaa(:,:,:) = 0 -DO JMLOC=1,D%NUMP - KM = D%MYMS(JMLOC) - KDGLU = MIN(R%NDGNH,G%NDGLU(KM)) - - ILA = (R%NSMAX-KM+2)/2 - DO JK=1,KDGLU - DO J=1,ILA - ZAA(JK,J,JMLOC)=S%FA(JMLOC)%RPNMA(JK,J) - ENDDO - ENDDO -ENDDO +write(nout,*)'setup_trans: sizes1 NUMP=',D%NUMP +write(nout,*)'ZAS:',size(ZAS) +write(nout,*)'ZAA:',size(ZAA) +ZAA(:,:,:) = 0 ZAS(:,:,:) = 0 DO JMLOC=1,D%NUMP KM = D%MYMS(JMLOC) - KDGLU = MIN(R%NDGNH,G%NDGLU(KM)) - + KDGLU = G%NDGLU(KM) + ILA = (R%NSMAX-KM+2)/2 ILS = (R%NSMAX-KM+3)/2 - DO JK=1,KDGLU - DO J=1,ILS - ZAS(JK,J,JMLOC)=S%FA(JMLOC)%RPNMS(JK,J) - ENDDO - ENDDO -ENDDO - -! permanent copy of Legendre polynomials into device - -!$ACC update device(ZAA) -!$ACC update device(ZAS) -IF_FOUBUF=MAX(IF_OUT_LT,IF_FS) -ALLOCATE(FOUBUF_IN(MAX(1,D%NLENGT0B*2*IF_FOUBUF))) -ALLOCATE(FOUBUF(MAX(1,D%NLENGT0B*2*IF_FOUBUF))) -! memory save - -ALLOCATE(ZGTF(2*IF_FS,D%NLENGTF)) -write(nout,*)'ZGTF :',size(ZGTF) -!$ACC enter data create(ZGTF) + ZAA(1:KDGLU,1:ILA,JMLOC)=S%FA(JMLOC)%RPNMA(1:KDGLU,1:ILA) + ZAS(1:KDGLU,1:ILS,JMLOC)=S%FA(JMLOC)%RPNMS(1:KDGLU,1:ILS) +ENDDO +!$ACC ENTER DATA COPYIN(ZAA,ZAS) -ALLOCATE(ZIA(IF_FS_INV0,R%NLEI1,D%NUMP)) ALLOCATE(ZEPSNM(d%nump,0:R%NTMAX+2)) -ALLOCATE(ZSOA1(2*IF_OUT_LT,R%NLEI3,D%NUMP)) -ALLOCATE(ZAOA1(2*IF_OUT_LT,R%NLEI3,D%NUMP)) -ALLOCATE(ISTAN(D%NUMP,R%NDGNH)) -ALLOCATE(ISTAS(D%NUMP,R%NDGNH)) -!ALLOCATE(ZSIA(IF_FS_INV0,R%NDGNH,D%NUMP)) -ALLOCATE(ZAIA(IF_FS_INV0,R%NDGNH,D%NUMP)) -ALLOCATE(ZOA1(4*IF_FS_DIR0,R%NLED4,D%NUMP)) -ALLOCATE(ZOA2(MAX(4*IF_UV,1),R%NLED4,D%NUMP)) -write(nout,*)'ZIA :',size(ZIA ) -write(nout,*)'ZSOA1:',size(ZSOA1) -write(nout,*)'ZAOA1:',size(ZAOA1) -write(nout,*)'ZAIA :',size(ZAIA ) -write(nout,*)'ZOA1 :',size(ZOA1 ) -write(nout,*)'ZOA2 :',size(ZOA2 ) -!!!$ACC enter data create(ZIA,ZEPSNM,ZSOA1,ZAOA1,ISTAN,ISTAS,ZSIA,ZAIA,ZOA1,ZOA2) -!$ACC enter data create(ZIA,ZEPSNM,ZSOA1,ZAOA1,ZAIA,ZOA1,ZOA2) - -zepsnm = 0._JPRBT +write(nout,*)'ZEPSNM :',size(ZEPSNM) +ZEPSNM = 0._JPRBT CALL PREPSNM -!$acc update device(zepsnm) -zgtf = 0._JPRBT -!$acc update device(zgtf) -zia = 0._JPRBT -!$acc update device(zia) -!zsia = 0._JPRBT -!!!$acc update device(zsia) -zaia = 0._JPRBT -!$acc update device(zaia) -zoa1 = 0._JPRBT -!$acc update device(zoa1) -zoa2 = 0._JPRBT -!$acc update device(zoa2) -zaoa1 = 0._JPRBT -!$acc update device(zaoa1) -zsoa1 = 0._JPRBT -!$acc update device(zsoa1) - -! add arrays for GPNORM1 -ALLOCATE(ZAVE(IF_FS,R%NDGL)) -ALLOCATE(ZMINGL(IF_FS,R%NDGL)) -ALLOCATE(ZMAXGL(IF_FS,R%NDGL)) -ALLOCATE(ZMINGPN(IF_FS)) -ALLOCATE(ZMAXGPN(IF_FS)) -!$ACC enter data create(ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) - -zave = 0._JPRBT -!$acc update device(zave) -zmingl = 0._JPRBT -!$acc update device(zmingl) -zmaxgl = 0._JPRBT -!$acc update device(zmaxgl) -zmingpn = 0._JPRBT -!$acc update device(zmingpn) -zmaxgpn = 0._JPRBT -!$acc update device(zmaxgpn) +!$ACC ENTER DATA COPYIN(ZEPSNM) !set up flat copies of constant data R_NSMAX=R%NSMAX R_NTMAX=R%NTMAX R_NDGNH=R%NDGNH R_NDGL=R%NDGL -R_NNOEXTZL=R%NNOEXTZL - - -ALLOCATE(D_NSTAGT0B(SIZE(D%NSTAGT0B))) -ALLOCATE(D_NSTAGT1B(SIZE(D%NSTAGT1B))) -ALLOCATE(D_NPNTGTB0(0:SIZE(D%NPNTGTB0,1)-1,SIZE(D%NPNTGTB0,2))) -ALLOCATE(D_NPNTGTB1(SIZE(D%NPNTGTB1,1),SIZE(D%NPNTGTB1,2))) -ALLOCATE(D_MYMS(SIZE(D%MYMS))) -ALLOCATE(D_NPROCL(SIZE(D%NPROCL))) -ALLOCATE(D_NASM0(0:SIZE(D%NASM0)-1)) -ALLOCATE(D_NSTAGTF(SIZE(D%NSTAGTF))) -ALLOCATE(D_MSTABF(SIZE(D%MSTABF))) -ALLOCATE(D_NPROCM(0:SIZE(D%NPROCM)-1)) -ALLOCATE(D_NPTRLS(SIZE(D%NPTRLS))) - -ALLOCATE(G_NDGLU(0:SIZE(G%NDGLU)-1)) -ALLOCATE(G_NMEN(SIZE(G%NMEN))) -ALLOCATE(G_NLOEN(SIZE(G%NLOEN))) - -ALLOCATE(F_RW(SIZE(F%RW))) - - -DO I=0,SIZE(G%NDGLU)-1 - G_NDGLU(I)=G%NDGLU(I) -end DO - -G_NMEN_MAX=0 -DO I=1,SIZE(G%NMEN) - G_NMEN(I)=G%NMEN(I) - if (G_NMEN(I) .gt. G_NMEN_MAX) G_NMEN_MAX=G_NMEN(I) -end DO - -G_NLOEN_MAX=0 -DO I=1,SIZE(G%NLOEN) - G_NLOEN(I)=G%NLOEN(I) - if (G_NLOEN(I) .gt. G_NLOEN_MAX) G_NLOEN_MAX=G_NLOEN(I) -end DO - -DO I=1,SIZE(D%NSTAGT0B) - D_NSTAGT0B(I)=D%NSTAGT0B(I) -END DO - -DO I=1,SIZE(D%NSTAGT1B) - D_NSTAGT1B(I)=D%NSTAGT1B(I) -END DO - -DO I=1,SIZE(D%NPROCL) - D_NPROCL(I)=D%NPROCL(I) -END DO - -DO I=0,SIZE(D%NASM0)-1 - D_NASM0(I)=D%NASM0(I) -END DO - -DO I=1,SIZE(D%NSTAGTF) - D_NSTAGTF(I)=D%NSTAGTF(I) -END DO - -DO I=1,SIZE(D%MSTABF) - D_MSTABF(I)=D%MSTABF(I) -END DO - -DO I=0,SIZE(D%NPROCM)-1 - D_NPROCM(I)=D%NPROCM(I) -END DO - -DO I=1,SIZE(D%NPTRLS) - D_NPTRLS(I)=D%NPTRLS(I) -END DO - -DO I=1,SIZE(D%NPNTGTB0,2) - DO J=0,SIZE(D%NPNTGTB0,1)-1 - D_NPNTGTB0(J,I)=D%NPNTGTB0(J,I) - end DO -END DO - -DO I=1,SIZE(D%NPNTGTB1,2) - DO J=1,SIZE(D%NPNTGTB1,1) - D_NPNTGTB1(J,I)=D%NPNTGTB1(J,I) - end DO -END DO + +G_NDGLU => G%NDGLU + +G_NMEN => G%NMEN +G_NMEN_MAX=MAXVAL(G_NMEN) + +G_NLOEN => G%NLOEN +G_NLOEN_MAX=MAXVAL(G_NLOEN) + +D_NSTAGT0B => D%NSTAGT0B +D_NSTAGT1B => D%NSTAGT1B + +D_NPROCL => D%NPROCL +D_NASM0 => D%NASM0 +D_NSTAGTF => D%NSTAGTF +D_MSTABF => D%MSTABF +D_NPROCM => D%NPROCM +D_NPTRLS => D%NPTRLS + +D_NPNTGTB0 => D%NPNTGTB0 +D_NPNTGTB1 => D%NPNTGTB1 + +D_OFFSETS_GEMM1 => D%OFFSETS_GEMM1 +D_OFFSETS_GEMM2 => D%OFFSETS_GEMM2 D_NUMP=D%NUMP -KMLOC0 = -1 -DO I=1,SIZE(D%MYMS) - D_MYMS(I)=D%MYMS(I) - IF(D_MYMS(I) == 0) KMLOC0 = I -end DO +KMLOC0 = FINDLOC(D%MYMS, VALUE=0, DIM=1) +D_MYMS => D%MYMS ! arrays for m=0 in ledir_mod: -IF(KMLOC0 >= 0) THEN - ALLOCATE(ZAA0(R%NDGNH,TDZAA)) - ALLOCATE(ZAS0(R%NDGNH,TDZAS)) - ALLOCATE(DZBST0(IF_FS_DIR0*R%NDGNH)) - ALLOCATE(DZCAT0(IF_FS_DIR0*TDZAA)) - ALLOCATE(DZCST0(IF_FS_DIR0*TDZAS)) - DZCAT0(:) = 0 - DZCST0(:) = 0 - !$ACC ENTER DATA COPYIN(ZAA0,DZBST0,DZCAT0,ZAS0,DZCST0) +IF(KMLOC0 > 0) THEN + ALLOCATE(ZAA0(SIZE(ZAA,1),SIZE(ZAA,2))) + ALLOCATE(ZAS0(SIZE(ZAS,1),SIZE(ZAS,2))) ZAA0 = ZAA(:,:,KMLOC0) ZAS0 = ZAS(:,:,KMLOC0) - !$ACC update device(ZAA0) - !$ACC update device(ZAS0) - dzbst0 = 0._JPRD - !$acc update device(dzbst0) + !$ACC ENTER DATA COPYIN(ZAA0,ZAS0) WRITE(NOUT,*) 'GPU arrays for m=0 successfully allocated' ENDIF -DO I=1,SIZE(F%RW) - F_RW(I)=F%RW(I) -END DO +F_RW => F%RW -!$ACC ENTER DATA COPYIN(R_NSMAX,R_NTMAX,R_NDGL,R_NNOEXTZL,R_NDGNH,D_NSTAGT0B,D_NSTAGT1B,& -!$ACC& D_NPNTGTB1,D_NPROCL,D_NUMP,D_MYMS,D_NASM0,D_NSTAGTF,D_MSTABF,& -!$ACC& D_NPNTGTB0,D_NPROCM,D_NPTRLS,G_NDGLU,G_NMEN,G_NMEN_MAX,G_NLOEN,& -!$ACC& G_NLOEN_MAX,F_RW) +!$ACC ENTER DATA COPYIN(D_NSTAGT0B,D_NSTAGT1B,& +!$ACC& D_NPNTGTB1,D_NPROCL,D_MYMS,D_NASM0,D_NSTAGTF,D_MSTABF,& +!$ACC& D_NPNTGTB0,D_NPROCM,D_NPTRLS,G_NDGLU,G_NMEN,G_NLOEN,& +!$ACC& F_RW,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2) WRITE(NOUT,*) '===GPU arrays successfully allocated' -!$ACC wait ! free memory !DO JMLOC=1,D%NUMP diff --git a/src/trans/gpu/external/trans_end.F90 b/src/trans/gpu/external/trans_end.F90 index 69d45f9ab..cc03abc6d 100755 --- a/src/trans/gpu/external/trans_end.F90 +++ b/src/trans/gpu/external/trans_end.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -45,23 +46,18 @@ SUBROUTINE TRANS_END(CDMODE) !ifndef INTERFACE USE TPM_GEN ,ONLY : MSETUP0, NCUR_RESOL, NMAX_RESOL, LENABLED,NDEF_RESOL -USE TPM_DIM ,ONLY : R, DIM_RESOL, R_NSMAX,R_NTMAX, R_NDGNH, R_NDGL, R_NNOEXTZL +USE TPM_DIM ,ONLY : R, DIM_RESOL, R_NSMAX,R_NTMAX, R_NDGNH, R_NDGL USE TPM_DISTR ,ONLY : D, DISTR_RESOL, NPRCIDS,D_NUMP,D_MYMS,D_NSTAGT0B,D_NSTAGT1B,D_NPROCL,D_NPNTGTB1, D_NASM0, & & D_NSTAGTF,D_MSTABF,D_NPNTGTB0,D_NPROCM,D_NPTRLS USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL, G_NDGLU, G_NMEN, G_NMEN_MAX,G_NLOEN, G_NLOEN_MAX -USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL,F_RW, ZIA,ZEPSNM,ZSOA1,ZAOA1,ISTAN,ISTAS,ZSIA,ZAIA,ZOA1,ZOA2, & -& ZAA,ZAS,LDZAA,LDZAS,TDZAA,TDZAS,& -& IZBS,ILDZBA,ILDZBS,ITDZBA,ITDZBS,& -& IZCA,IZCS,IZCST,ILDZCA,ILDZCS,ITDZCA,ITDZCS,& -& DZBAT,DZBST,DLDZBA,DLDZBS,DTDZBA,DTDZBS,& -& DZCA,DZCS,DZCAT,DZCST,DLDZCA,DLDZCS,DTDZCA,DTDZCS +USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL,F_RW, ZEPSNM,ZAA,ZAS,ZAA0,ZAS0 USE TPM_FFT ,ONLY : T, FFT_RESOL USE TPM_CTL ,ONLY : C, CTL_RESOL #ifdef WITH_FFTW USE TPM_FFTW ,ONLY : TW, FFTW_RESOL #endif USE TPM_FLT -USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN, ZGTF +USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE EQ_REGIONS_MOD ,ONLY : N_REGIONS USE SET_RESOL_MOD ,ONLY : SET_RESOL @@ -78,50 +74,15 @@ SUBROUTINE TRANS_END(CDMODE) IF (PRESENT(CDMODE)) CLMODE=CDMODE IF (CLMODE == 'FINAL') THEN + !$ACC EXIT DATA DELETE(ZAA0,ZAS0,ZEPSNM,ZAA,ZAS) + DEALLOCATE(ZAA0) + DEALLOCATE(ZAS0) + DEALLOCATE(ZEPSNM) DEALLOCATE(ZAA) DEALLOCATE(ZAS) - - !DEALLOCATE(IZBA) - DEALLOCATE(IZBS) - !DEALLOCATE(IZCA) - !DEALLOCATE(IZCS) - !DEALLOCATE(IZCAT) - DEALLOCATE(IZCST) - - - !DEALLOCATE(DZBA) - !DEALLOCATE(DZBS) - DEALLOCATE(DZBAT) - DEALLOCATE(DZBST) - !DEALLOCATE(DZCA) - !DEALLOCATE(DZCS) - DEALLOCATE(DZCAT) - DEALLOCATE(DZCST) - - !$ACC exit data delete(ZAA,ZAS,IZBS,IZCST,DZBAT,DZBST,DZCAT,DZCST) - - !memory save - DEALLOCATE(FOUBUF_IN) - DEALLOCATE(FOUBUF) - - - !$ACC exit data delete(ZGTF) - DEALLOCATE(ZGTF) - - DEALLOCATE(ZIA) - DEALLOCATE(ZEPSNM) - DEALLOCATE(ZSOA1) - DEALLOCATE(ZAOA1) - DEALLOCATE(ISTAN) - DEALLOCATE(ISTAS) - DEALLOCATE(ZSIA) - DEALLOCATE(ZAIA) - DEALLOCATE(ZOA1) - !DEALLOCATE(ZOA2) - !$ACC exit data delete(ZIA,ZEPSNM,ZSOA1,ZAOA1,ISTAN,ISTAS,ZSIA,ZAIA,ZOA1) - + DEALLOCATE(D_NSTAGT0B,D_NSTAGT1B,D_NPNTGTB1,D_MYMS,D_NPROCL,D_NASM0,D_NSTAGTF,D_MSTABF,D_NPNTGTB0,D_NPROCM,D_NPTRLS,G_NDGLU,G_NMEN,G_NLOEN,F_RW) - !$ACC exit data delete(R_NSMAX,R_NTMAX,R_NDGL,R_NNOEXTZL,R_NDGNH,D_NSTAGT0B,D_NSTAGT1B,D_NPNTGTB1,D_NPROCL,D_NUMP,D_MYMS,G_NDGLU,G_NMEN,G_NMEN_MAX,G_NLOEN,G_NLOEN_MAX,D_NSTAGTF,D_MSTABF,D_NPNTGTB0,D_NPROCM,D_NPTRLS,D_NASM0,F_RW) + !$ACC EXIT DATA DELETE(D_NSTAGT0B,D_NSTAGT1B,D_NPNTGTB1,D_NPROCL,D_MYMS,G_NDGLU,G_NMEN,G_NLOEN,D_NSTAGTF,D_MSTABF,D_NPNTGTB0,D_NPROCM,D_NPTRLS,D_NASM0,F_RW) !call CUDA_DGEMM_BATCHED_FINALIZE() diff --git a/src/trans/gpu/external/vordiv_to_uv.F90 b/src/trans/gpu/external/vordiv_to_uv.F90 deleted file mode 100755 index 6b7a71e83..000000000 --- a/src/trans/gpu/external/vordiv_to_uv.F90 +++ /dev/null @@ -1,178 +0,0 @@ -! (C) Copyright 2015- 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 VORDIV_TO_UV(PSPVOR,PSPDIV,PSPU,PSPV,KSMAX,KVSETUV) - -!**** *VORDIV_TO_UV* - Convert spectral vorticity and divergence to spectral U (u*cos(theta)) and V (v*cos(theta). - -! Purpose. -! -------- -! Interface routine for Convert spectral vorticity and divergence to spectral U and V - -!** Interface. -! ---------- -! CALL VORDIV_TO_UV(...) - -! Explicit arguments : -! -------------------- -! PSPVOR(:,:) - spectral vorticity (input) -! PSPDIV(:,:) - spectral divergence (input) -! PSPU(:,:) - spectral U (u*cos(theta) (output) -! PSPV(:,:) - spectral V (v*cos(theta) (output) -! KSMAX - spectral resolution (input) -! KVSETUV(:) - Optionally indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. - -! Method. -! ------- - -! Externals. SET_RESOL - set resolution -! ---------- VD2UV_CTL - control vordiv to uv - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 15-06-15 - - -! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -!ifndef INTERFACE - -USE TPM_GEN ,ONLY : NERR, NOUT,MSETUP0 -USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV - -USE SET_RESOL_MOD ,ONLY : SET_RESOL -USE VD2UV_CTL_MOD ,ONLY : VD2UV_CTL -USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -!endif INTERFACE - -IMPLICIT NONE - -! Declaration of arguments - -REAL(KIND=JPRB), INTENT(IN) :: PSPVOR(:,:) -REAL(KIND=JPRB), INTENT(IN) :: PSPDIV(:,:) -REAL(KIND=JPRB), INTENT(OUT) :: PSPU(:,:) -REAL(KIND=JPRB), INTENT(OUT) :: PSPV(:,:) -INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) - -!ifndef INTERFACE - -! Local varaibles -INTEGER(KIND=JPIM) :: IUBOUND(4),J -INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IRESOL,IDGL -LOGICAL :: LTMP_SETUP0 -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -#include "setup_trans0.h" -#include "setup_trans.h" -#include "trans_release.h" -#include "trans_end.h" - -! ------------------------------------------------------------------ - -IF (LHOOK) CALL DR_HOOK('VORDIV_TO_UV',0,ZHOOK_HANDLE) - -!CALL GSTATS(XXXX,0) - -IF(MSETUP0 == 0) THEN - CALL SETUP_TRANS0() - LTMP_SETUP0 = .TRUE. -ELSE - LTMP_SETUP0 = .FALSE. -ENDIF -IDGL = 2 ! It doesn't matter as long as it's a positive even number -CALL SETUP_TRANS(KSMAX,IDGL,LDSPSETUPONLY=.TRUE.,KRESOL=IRESOL) -CALL SET_RESOL(IRESOL) - - -! Set defaults - -IF_UV = 0 -IF_UV_G = 0 -! Decide requirements - -IF(PRESENT(KVSETUV)) THEN - IF_UV_G = UBOUND(KVSETUV,1) - DO J=1,IF_UV_G - IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN - WRITE(NERR,*) 'VORDIV_TO_UV:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV - CALL ABORT_TRANS('VORDIV_TO_UV:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') - ENDIF - IF(KVSETUV(J) == MYSETV) THEN - IF_UV = IF_UV+1 - ENDIF - ENDDO -ELSE - IF_UV = UBOUND(PSPVOR,1) - IF_UV_G = IF_UV -ENDIF - -! Consistency checks - -IF (IF_UV > 0) THEN - IF(UBOUND(PSPVOR,1) < IF_UV) THEN - WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV - CALL ABORT_TRANS('VORDIV_TO_UV : PSPVOR TOO SHORT') - ENDIF - IF(UBOUND(PSPDIV,1) < IF_UV) THEN - WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV - CALL ABORT_TRANS('VORDIV_TO_UV : PSPDIV TOO SHORT') - ENDIF - IF(UBOUND(PSPU,1) < IF_UV) THEN - WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPU,1) < IF_UV ',UBOUND(PSPU,1),IF_UV - CALL ABORT_TRANS('VORDIV_TO_UV : PSPU TOO SHORT') - ENDIF - IF(UBOUND(PSPV,1) < IF_UV) THEN - WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPV,1) < IF_UV ',UBOUND(PSPV,1),IF_UV - CALL ABORT_TRANS('VORDIV_TO_UV : PSPV TOO SHORT') - ENDIF -ENDIF - - -IF(NPRTRV >1) THEN - IF(IF_UV > 0 .AND. .NOT. PRESENT(KVSETUV)) THEN - WRITE(NERR,*)'NPRTRV >1 AND IF_UV > 0 AND NOT PRESENT(KVSETUV)',& - &NPRTRV,IF_UV - CALL ABORT_TRANS('VORDIV_TO_UV: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') - ENDIF -ENDIF - -!CALL GSTATS(XXXX,1) - -! ------------------------------------------------------------------ - -! Perform transform - -CALL VD2UV_CTL(IF_UV,PSPVOR,PSPDIV,PSPU,PSPV) - -CALL TRANS_RELEASE(IRESOL) -IF (LTMP_SETUP0) THEN - CALL TRANS_END() -ENDIF - -IF (LHOOK) CALL DR_HOOK('VORDIV_TO_UV',1,ZHOOK_HANDLE) -! ------------------------------------------------------------------ - -!endif INTERFACE - -END SUBROUTINE VORDIV_TO_UV - diff --git a/src/trans/gpu/internal/allocator_mod.F90 b/src/trans/gpu/internal/allocator_mod.F90 new file mode 100644 index 000000000..521d82cd6 --- /dev/null +++ b/src/trans/gpu/internal/allocator_mod.F90 @@ -0,0 +1,214 @@ +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) +MODULE ALLOCATOR_MOD + + USE PARKIND_ECTRANS ,ONLY : JPIM + USE ISO_C_BINDING, ONLY: C_INT8_T, C_SIZE_T + + IMPLICIT NONE + + ! The buffered allocator uses double buffering. The idea is that the allocator + ! iterates through its two buffers, and each allocate returns one or the other + ! buffer. It is a two-step allocator - it expects you to create reservation + ! handles first for all allocations. Then the allocator is instantiated (i.e. + ! the buffers are actually allocated). Instantiation will do an allocation + ! that is large enough two hold all consecutive allocations. Other allocations + ! might be overwritten (like you can't access the allocation done two steps + ! before). + ! After instantiation, you can retrieve your buffers by passing the allocator + ! and the handles to GET_ALLOCATION. Also, we provide helper function + ! ASSIGN_PTR, because an allocation is often split among several "sub-buffers", + ! so you can for example assign the first half of an allocation to one + ! buffer, while the second half to another buffer. + ! If you see "Logical errors" that usually means you try to retrieve a buffer + ! that is not within the reserved allocation size. This might be a valid + ! region in the sense that it is physically allocated, but it might be part of + ! the double buffer. + + + INTEGER(KIND=JPIM), PARAMETER :: NBUF = 2 + TYPE BUFFERED_ALLOCATOR + INTEGER(KIND=C_SIZE_T) :: BUFR_SZ(0:NBUF-1) + INTEGER(KIND=JPIM) :: NEXT_BUF + INTEGER(C_INT8_T), POINTER :: PTR(:) + END TYPE + TYPE ALLOCATION_RESERVATION_HANDLE + INTEGER(KIND=C_SIZE_T) :: SZ + INTEGER(KIND=JPIM) :: BUF + END TYPE + + INTERFACE ASSIGN_PTR + SUBROUTINE ASSIGN_PTR_FLOAT(DST, SRC, START_IN_BYTES, LENGTH_IN_BYTES, SET_VALUE, SET_STREAM) + USE ISO_C_BINDING + IMPLICIT NONE + INTEGER(KIND=C_INT8_T), POINTER, INTENT(INOUT) :: SRC(:) + REAL(KIND=C_FLOAT), POINTER, INTENT(OUT) :: DST(:) + INTEGER(KIND=C_SIZE_T) :: START_IN_BYTES, LENGTH_IN_BYTES + LOGICAL, INTENT(IN), OPTIONAL :: SET_VALUE + INTEGER(KIND=4), INTENT(IN), OPTIONAL :: SET_STREAM + END SUBROUTINE + SUBROUTINE ASSIGN_PTR_DOUBLE(DST, SRC, START_IN_BYTES, LENGTH_IN_BYTES, SET_VALUE, SET_STREAM) + USE ISO_C_BINDING + IMPLICIT NONE + INTEGER(KIND=C_INT8_T), POINTER, INTENT(INOUT) :: SRC(:) + REAL(KIND=C_DOUBLE), POINTER, INTENT(OUT) :: DST(:) + INTEGER(KIND=C_SIZE_T) :: START_IN_BYTES, LENGTH_IN_BYTES + LOGICAL, INTENT(IN), OPTIONAL :: SET_VALUE + INTEGER(KIND=4), INTENT(IN), OPTIONAL :: SET_STREAM + END SUBROUTINE + END INTERFACE + +CONTAINS + + ! TODO This is not perfect yet. We will over-allocate up to 2X in theory. + ! It would be better to always keep the previous allocation size and then + ! have one allocation sitting at the the top, and the double-buffer at + ! the bottom of the allocation. + + FUNCTION MAKE_BUFFERED_ALLOCATOR() + IMPLICIT NONE + TYPE(BUFFERED_ALLOCATOR) :: MAKE_BUFFERED_ALLOCATOR + + MAKE_BUFFERED_ALLOCATOR%BUFR_SZ(:) = 0 + MAKE_BUFFERED_ALLOCATOR%NEXT_BUF = 0 + END FUNCTION + + FUNCTION RESERVE(ALLOCATOR, SZ) + IMPLICIT NONE + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=C_SIZE_T), INTENT(IN) :: SZ + + TYPE(ALLOCATION_RESERVATION_HANDLE) :: RESERVE + + ALLOCATOR%BUFR_SZ(ALLOCATOR%NEXT_BUF) = MAX(ALLOCATOR%BUFR_SZ(ALLOCATOR%NEXT_BUF),SZ) + RESERVE%BUF = ALLOCATOR%NEXT_BUF + RESERVE%SZ = SZ + + ALLOCATOR%NEXT_BUF = MOD(ALLOCATOR%NEXT_BUF+1,NBUF) + END FUNCTION + + SUBROUTINE INSTANTIATE_ALLOCATOR(ALLOCATOR, OLD_PTR) + IMPLICIT NONE + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(C_INT8_T), OPTIONAL, INTENT(INOUT), POINTER :: OLD_PTR(:) + INTEGER :: I + + DO I = 0, NBUF-1 + ALLOCATOR%BUFR_SZ(I) = ALIGN(ALLOCATOR%BUFR_SZ(I),128) + ENDDO + + IF (ASSOCIATED(OLD_PTR)) THEN + IF (SIZEOF(OLD_PTR) < SUM(ALLOCATOR%BUFR_SZ) ) THEN + !$ACC EXIT DATA DELETE(OLD_PTR) IF(PRESENT(OLD_PTR)) + DEALLOCATE(OLD_PTR) + NULLIFY(OLD_PTR) + ALLOCATE(ALLOCATOR%PTR(1:SUM(ALLOCATOR%BUFR_SZ))) + !$ACC ENTER DATA CREATE(ALLOCATOR%PTR) + + OLD_PTR => ALLOCATOR%PTR + ELSE + ALLOCATOR%PTR(1:) => OLD_PTR(1:) + ENDIF + ELSE + ALLOCATE(ALLOCATOR%PTR(1:SUM(ALLOCATOR%BUFR_SZ))) + !$ACC ENTER DATA CREATE(ALLOCATOR%PTR) + OLD_PTR => ALLOCATOR%PTR + ENDIF + END SUBROUTINE + + FUNCTION GET_ALLOCATION(ALLOCATOR, RESERVATION) + IMPLICIT NONE + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(ALLOCATION_RESERVATION_HANDLE), INTENT(IN) :: RESERVATION + + INTEGER(KIND=C_INT8_T), POINTER :: GET_ALLOCATION(:) + + IF (RESERVATION%SZ > ALLOCATOR%BUFR_SZ(RESERVATION%BUF)) THEN + PRINT *, "Logical Error in GET_ALLOCATOIN" + STOP 4 + ENDIF + IF (RESERVATION%BUF == 0) THEN + GET_ALLOCATION(1:) => ALLOCATOR%PTR(1:RESERVATION%SZ) + ELSE + GET_ALLOCATION(1:) => ALLOCATOR%PTR(SUM(ALLOCATOR%BUFR_SZ(0:RESERVATION%BUF-1))+1: & + SUM(ALLOCATOR%BUFR_SZ(0:RESERVATION%BUF-1))+RESERVATION%SZ) + ENDIF + END FUNCTION + + SUBROUTINE ASSIGN_PTR_FLOAT(DST, SRC, START_IN_BYTES, LENGTH_IN_BYTES, SET_VALUE, SET_STREAM) + USE ISO_C_BINDING + USE OPENACC, ONLY: ACC_ASYNC_SYNC + IMPLICIT NONE + INTEGER(KIND=C_INT8_T), POINTER, INTENT(INOUT) :: SRC(:) + REAL(KIND=C_FLOAT), POINTER, INTENT(OUT) :: DST(:) + LOGICAL, INTENT(IN), OPTIONAL :: SET_VALUE + INTEGER(KIND=4), INTENT(IN), OPTIONAL :: SET_STREAM + LOGICAL :: SET_VALUE_EFF + INTEGER(KIND=4) :: SET_STREAM_EFF + INTEGER(KIND=C_SIZE_T) :: START_IN_BYTES, LENGTH_IN_BYTES + IF (START_IN_BYTES + LENGTH_IN_BYTES - 1 > SIZE(SRC, KIND=C_SIZE_T)) THEN + PRINT *, "Logical Error in ASSIGN_PTR - OOB assignment" + STOP 4 + ENDIF + IF (PRESENT(SET_VALUE)) THEN + SET_VALUE_EFF = SET_VALUE + ELSE + SET_VALUE_EFF = .FALSE. + ENDIF + IF (PRESENT(SET_STREAM)) THEN + SET_STREAM_EFF = SET_STREAM + ELSE + SET_STREAM_EFF = ACC_ASYNC_SYNC + ENDIF + IF (SET_VALUE_EFF .AND. LENGTH_IN_BYTES > 0) THEN + ! This option is turned off by default, but for experimentation we can turn it on. This is + ! setting all bits to 1 (meaning NaN in floating point) + !$ACC KERNELS PRESENT(SRC) ASYNC(SET_STREAM_EFF) + SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1) = -1 + !$ACC END KERNELS LOOP + ENDIF + CALL C_F_POINTER(C_LOC(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1)), DST, & + & [SIZEOF(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1))/SIZEOF(DST(0))]) + END SUBROUTINE + SUBROUTINE ASSIGN_PTR_DOUBLE(DST, SRC, START_IN_BYTES, LENGTH_IN_BYTES, SET_VALUE, SET_STREAM) + USE ISO_C_BINDING + USE OPENACC, ONLY: ACC_ASYNC_SYNC + IMPLICIT NONE + INTEGER(KIND=C_INT8_T), POINTER, INTENT(INOUT) :: SRC(:) + REAL(KIND=C_DOUBLE), POINTER, INTENT(OUT) :: DST(:) + LOGICAL, INTENT(IN), OPTIONAL :: SET_VALUE + INTEGER(KIND=4), INTENT(IN), OPTIONAL :: SET_STREAM + LOGICAL :: SET_VALUE_EFF + INTEGER(KIND=4) :: SET_STREAM_EFF + INTEGER(KIND=C_SIZE_T) :: START_IN_BYTES, LENGTH_IN_BYTES + IF (START_IN_BYTES + LENGTH_IN_BYTES - 1 > SIZE(SRC, KIND=C_SIZE_T)) THEN + PRINT *, "Logical Error in ASSIGN_PTR - OOB assignment" + STOP 4 + ENDIF + IF (PRESENT(SET_VALUE)) THEN + SET_VALUE_EFF = SET_VALUE + ELSE + SET_VALUE_EFF = .FALSE. + ENDIF + IF (PRESENT(SET_STREAM)) THEN + SET_STREAM_EFF = SET_STREAM + ELSE + SET_STREAM_EFF = ACC_ASYNC_SYNC + ENDIF + IF (SET_VALUE_EFF .AND. LENGTH_IN_BYTES > 0) THEN + ! This option is turned off by default, but for experimentation we can turn it on. This is + ! setting all bits to 1 (meaning NaN in floating point) + !$ACC KERNELS PRESENT(SRC) ASYNC(SET_STREAM_EFF) + SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1) = -1 + !$ACC END KERNELS LOOP + ENDIF + CALL C_F_POINTER(C_LOC(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1)), DST, & + & [SIZEOF(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1))/SIZEOF(DST(0))]) + END SUBROUTINE +END MODULE diff --git a/src/trans/gpu/internal/asre1_mod.F90 b/src/trans/gpu/internal/asre1_mod.F90 deleted file mode 100755 index 025502bd9..000000000 --- a/src/trans/gpu/internal/asre1_mod.F90 +++ /dev/null @@ -1,97 +0,0 @@ -! (C) Copyright 2001- 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 ASRE1_MOD -CONTAINS -SUBROUTINE ASRE1(KM,KMLOC,KF_OUT_LT,PAOA1,PSOA1) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT -USE TPM_DIM ,ONLY : R - -!USE TPM_TRANS - -USE ASRE1B_MOD ,ONLY : ASRE1B - - -!**** *ASRE1* - Recombine antisymmetric and symmetric parts - -! Purpose. -! -------- -! To recombine the antisymmetric and symmetric parts of the -! Fourier arrays and update the correct parts of the state -! variables. - -!** Interface. -! ---------- -! *CALL* *ASRE1(...) - -! Explicit arguments : -! -------------------- -! KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PAOA1 - antisymmetric part of Fourier -! fields for zonal wavenumber KM (basic -! variables and N-S derivatives) -! PSOA1 - symmetric part of Fourier -! fields for zonal wavenumber KM (basic -! variables and N-S derivatives) - -! Implicit arguments : None -! -------------------- - -! Method. -! ------- - -! Externals. ASRE1B - basic recombination routine -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From ASRE1 in IFS CY22R1 - -! ------------------------------------------------------------------ - - -IMPLICIT NONE - - -! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM) , INTENT(IN) :: KM -INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM) , INTENT(IN) :: KF_OUT_LT - -REAL(KIND=JPRBT) , INTENT(IN) :: PSOA1(:,:), PAOA1(:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IFLDS - -! WORK ARRAYS FOR ASREL1B -INTEGER(KIND=JPIM) :: ISTAN(R%NDGNH),ISTAS(R%NDGNH) - -stop 'Error: this code path is not (yet) supported in GPU version' - - -! ------------------------------------------------------------------ - -IFLDS = KF_OUT_LT - -!CALL ASRE1B(IFLDS,KM,KMLOC,PAOA1,PSOA1) - -! ------------------------------------------------------------------ - -END SUBROUTINE ASRE1 -END MODULE ASRE1_MOD diff --git a/src/trans/gpu/internal/asre1ad_mod.F90 b/src/trans/gpu/internal/asre1ad_mod.F90 deleted file mode 100755 index 2c9ca158a..000000000 --- a/src/trans/gpu/internal/asre1ad_mod.F90 +++ /dev/null @@ -1,91 +0,0 @@ -! (C) Copyright 2001- 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 ASRE1AD_MOD -CONTAINS -SUBROUTINE ASRE1AD(KM,KMLOC,KF_OUT_LT,PAOA1,PSOA1) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -!USE TPM_TRANS - -USE ASRE1BAD_MOD ,ONLY : ASRE1BAD - - -!**** *ASRE1AD* - Recombine antisymmetric and symmetric parts - adjoint - -! Purpose. -! -------- -! To recombine the antisymmetric and symmetric parts of the -! Fourier arrays and update the correct parts of the state -! variables. - -!** Interface. -! ---------- -! *CALL* *ASRE1AD(...) - -! Explicit arguments : -! -------------------- -! KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PAOA1 - antisymmetric part of Fourier -! fields for zonal wavenumber KM (basic -! variables and N-S derivatives) -! PSOA1 - symmetric part of Fourier -! fields for zonal wavenumber KM (basic -! variables and N-S derivatives) - -! Implicit arguments : None -! -------------------- - -! Method. -! ------- - -! Externals. ASRE1BAD - basic recombination routine -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From ASRE1AD in IFS CY22R1 - -! ------------------------------------------------------------------ - - -IMPLICIT NONE - - -! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM) , INTENT(IN) :: KM -INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM) , INTENT(IN) :: KF_OUT_LT - -REAL(KIND=JPRBT) , INTENT(OUT) :: PSOA1(:,:), PAOA1(:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IFLDS - - -! ------------------------------------------------------------------ - -IFLDS = KF_OUT_LT - -CALL ASRE1BAD(IFLDS,KM,KMLOC,PAOA1,PSOA1) - -! ------------------------------------------------------------------ - -END SUBROUTINE ASRE1AD -END MODULE ASRE1AD_MOD diff --git a/src/trans/gpu/internal/asre1b_mod.F90 b/src/trans/gpu/internal/asre1b_mod.F90 deleted file mode 100755 index cb31156aa..000000000 --- a/src/trans/gpu/internal/asre1b_mod.F90 +++ /dev/null @@ -1,110 +0,0 @@ -! (C) Copyright 2000- 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 ASRE1B_MOD -CONTAINS -SUBROUTINE ASRE1B(KFIELD,PAOA,PSOA) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DIM ,ONLY : R, R_NDGNH, R_NDGL -USE TPM_TRANS ,ONLY : FOUBUF_IN -USE TPM_GEOMETRY ,ONLY : G, G_NDGLU -USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS,D_NSTAGT0B,D_NSTAGT1B,D_NPROCL,D_NPNTGTB1 -use tpm_gen, only: nout - -!**** *ASRE1B* - Recombine antisymmetric and symmetric parts - -! Purpose. -! -------- -! To recombine the antisymmetric and symmetric parts of the -! Fourier arrays and update the correct parts of the state -! variables. - -!** Interface. -! ---------- -! *CALL* *ASRE1B(..) - -! Explicit arguments : -! ------------------- KFIELD - number of fields (input-c) -! KM - zonal wavenumber(input-c) -! KMLOC - local version of KM (input-c) -! PAOA - antisymmetric part of Fourier -! fields for zonal wavenumber KM (input) -! PSOA - symmetric part of Fourier -! fields for zonal wavenumber KM (input) - -! Implicit arguments : FOUBUF_IN - output buffer (output) -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From ASRE1B in IFS CY22R1 - -! ------------------------------------------------------------------ - - -IMPLICIT NONE - -INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD -INTEGER(KIND=JPIM) :: KM,KMLOC -REAL(KIND=JPRBT), INTENT(IN) :: PSOA(:,:,:) -REAL(KIND=JPRBT), INTENT(IN) :: PAOA(:,:,:) -!INTEGER(KIND=JPIM), INTENT(OUT) :: ISTAN(:,:) -!INTEGER(KIND=JPIM), INTENT(OUT) :: ISTAS(:,:) - -! LOCAL INTEGERS -INTEGER(KIND=JPIM) :: ISL, IGLS, JFLD, JGL ,IPROC, IPROCS, IDGNH, ISTAN, ISTAS - -! ------------------------------------------------------------------ - -!* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. -! --------------------------------------------------- - -!$ACC DATA PRESENT(PAOA,PSOA,D_MYMS,D_NPROCL,D_NSTAGT0B,D_NPNTGTB1,G_NDGLU) PRESENT(FOUBUF_IN) -!$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(KM,ISL,IPROC,ISTAN,IGLS,IPROCS,ISTAS) -DO KMLOC=1,D_NUMP - KM = D_MYMS(KMLOC) - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) - DO JGL=ISL, R_NDGNH -! if (JGL .ge. ISL) then - IPROC = D_NPROCL(JGL) - ISTAN = (D_NSTAGT0B(IPROC) + D_NPNTGTB1(KMLOC,JGL))*2*KFIELD - IGLS = R_NDGL+1-JGL - IPROCS = D_NPROCL(IGLS) - ISTAS = (D_NSTAGT0B(IPROCS) + D_NPNTGTB1(KMLOC,IGLS))*2*KFIELD - DO JFLD=1,2*KFIELD - !write(iunit,*) 'xx ', KM, KFIELD, ISL , KMLOC, JFLD, ISTAN, ISTAS, IGLS, JGL, IPROC, PAOA(JFLD,JGL,KMLOC), PSOA(JFLD,JGL,KMLOC) - !call flush(iunit) - FOUBUF_IN(ISTAN+JFLD) = PAOA(JFLD,JGL,KMLOC)+PSOA(JFLD,JGL,KMLOC) - FOUBUF_IN(ISTAS+JFLD) = PSOA(JFLD,JGL,KMLOC)-PAOA(JFLD,JGL,KMLOC) - ENDDO -! end if - ENDDO -ENDDO -!$ACC END DATA - -! ------------------------------------------------------------------ - -END SUBROUTINE ASRE1B -END MODULE ASRE1B_MOD diff --git a/src/trans/gpu/internal/asre1bad_mod.F90 b/src/trans/gpu/internal/asre1bad_mod.F90 deleted file mode 100755 index 34854f4ef..000000000 --- a/src/trans/gpu/internal/asre1bad_mod.F90 +++ /dev/null @@ -1,107 +0,0 @@ -! (C) Copyright 2000- 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 ASRE1BAD_MOD -CONTAINS -SUBROUTINE ASRE1BAD(KFIELD,KM,KMLOC,PAOA,PSOA) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_TRANS ,ONLY : FOUBUF_IN -USE TPM_GEOMETRY ,ONLY : G -USE TPM_DISTR ,ONLY : D - - -!**** *ASRE1BAD* - Recombine antisymmetric and symmetric parts - adjoint - -! Purpose. -! -------- -! To recombine the antisymmetric and symmetric parts of the -! Fourier arrays and update the correct parts of the state -! variables. - -!** Interface. -! ---------- -! *CALL* *ASRE1BAD(..) - -! Explicit arguments : -! ------------------- KFIELD - number of fields (input-c) -! KM - zonal wavenumber(input-c) -! KMLOC - local version of KM (input-c) -! PAOA - antisymmetric part of Fourier -! fields for zonal wavenumber KM (input) -! PSOA - symmetric part of Fourier -! fields for zonal wavenumber KM (input) - -! Implicit arguments : FOUBUF_IN - output buffer (output) -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From ASRE1BAD in IFS CY22R1 - -! ------------------------------------------------------------------ - - -IMPLICIT NONE - -INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD,KM,KMLOC -REAL(KIND=JPRBT), INTENT(OUT) :: PSOA(:,:) -REAL(KIND=JPRBT), INTENT(OUT) :: PAOA(:,:) - -! LOCAL INTEGERS -INTEGER(KIND=JPIM) :: ISL, IGLS, JFLD, JGL ,IPROC, IPROCS, IDGNH -INTEGER(KIND=JPIM) :: ISTAN(R%NDGNH),ISTAS(R%NDGNH) - -! ------------------------------------------------------------------ - -!* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. -! --------------------------------------------------- - -ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) -IDGNH = R%NDGNH - -!* 1.2 RECOMBINE - -DO JGL=ISL,IDGNH - IPROC = D%NPROCL(JGL) - ISTAN(JGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*2*KFIELD - IGLS = R%NDGL+1-JGL - IPROCS = D%NPROCL(IGLS) - ISTAS(JGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*2*KFIELD -ENDDO - -DO JGL=ISL,IDGNH -!OCL NOVREC - DO JFLD=1,2*KFIELD - PSOA(JFLD,JGL) = FOUBUF_IN(ISTAN(JGL)+JFLD)+FOUBUF_IN(ISTAS(JGL)+JFLD) - PAOA(JFLD,JGL) = FOUBUF_IN(ISTAN(JGL)+JFLD)-FOUBUF_IN(ISTAS(JGL)+JFLD) - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE ASRE1BAD -END MODULE ASRE1BAD_MOD - diff --git a/src/trans/gpu/internal/cuda_gemm_batched_mod.F90 b/src/trans/gpu/internal/cuda_gemm_batched_mod.F90 index 8032a1c28..3edf59305 100755 --- a/src/trans/gpu/internal/cuda_gemm_batched_mod.F90 +++ b/src/trans/gpu/internal/cuda_gemm_batched_mod.F90 @@ -1,137 +1,99 @@ +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 CUDA_GEMM_BATCHED_MOD - USE CUBLAS_MOD - USE PARKIND1, ONLY: JPRD, JPRM, JPIM, JPIB + USE PARKIND1, ONLY: JPRD, JPRM, JPIM + USE CUBLAS, ONLY: CUBLAS_OP_N, CUBLAS_OP_T + USE ISO_C_BINDING + USE OPENACC, ONLY: ACC_GET_CUDA_STREAM - IMPLICIT NONE + IMPLICIT NONE -!! PRIVATE - PUBLIC CUDA_GEMM_BATCHED, CUDA_DGEMM_BATCHED_OVERLOAD, CUDA_DGEMM_BATCHED_1D_OVERLOAD + PRIVATE + PUBLIC CUBLAS_OP_N, CUBLAS_OP_T + PUBLIC CUDA_GEMM_BATCHED INTERFACE CUDA_GEMM_BATCHED MODULE PROCEDURE CUDA_DGEMM_BATCHED_OVERLOAD MODULE PROCEDURE CUDA_SGEMM_BATCHED_OVERLOAD - MODULE PROCEDURE CUDA_SGEMM_STRIDED_BATCHED_OVERLOAD - MODULE PROCEDURE CUDA_DGEMM_BATCHED_1D_OVERLOAD - MODULE PROCEDURE CUDA_SGEMM_BATCHED_1D_OVERLOAD - MODULE PROCEDURE CUDA_SGEMM_STRIDED_BATCHED_1D_OVERLOAD - END INTERFACE CUDA_GEMM_BATCHED + MODULE PROCEDURE CUDA_DGEMM_GROUPED_OVERLOAD + MODULE PROCEDURE CUDA_SGEMM_GROUPED_OVERLOAD + END INTERFACE CUDA_GEMM_BATCHED -CONTAINS -SUBROUTINE CUDA_DGEMM_BATCHED_OVERLOAD( & - & TRANSA, TRANSB, & - & M, N, K, & - & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & - & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) -CHARACTER, INTENT(IN) :: TRANSA -CHARACTER, INTENT(IN) :: TRANSB -INTEGER(KIND=JPIM) :: M -INTEGER(KIND=JPIM) :: N -INTEGER(KIND=JPIM) :: K -REAL(KIND=JPRD) :: ALPHA -REAL(KIND=JPRD), DIMENSION(:,:,:) :: AARRAY -INTEGER(KIND=JPIM) :: LDA -INTEGER(KIND=JPIM) :: STRIDEA -REAL(KIND=JPRD), DIMENSION(:,:,:) :: BARRAY -INTEGER(KIND=JPIM) :: LDB -INTEGER(KIND=JPIM) :: STRIDEB -REAL(KIND=JPRD) :: BETA -REAL(KIND=JPRD), DIMENSION(:,:,:) :: CARRAY -INTEGER(KIND=JPIM) :: LDC -INTEGER(KIND=JPIM) :: STRIDEC -INTEGER(KIND=JPIM) :: BATCHCOUNT - -CALL CUDA_DGEMM_BATCHED( & - & TRANSA, TRANSB, & - & M, N, K, & - & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & - & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) -END SUBROUTINE CUDA_DGEMM_BATCHED_OVERLOAD - -SUBROUTINE CUDA_SGEMM_BATCHED_OVERLOAD( & - & TRANSA, TRANSB, & - & M, N, K, & - & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & - & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) -CHARACTER, INTENT(IN) :: TRANSA -CHARACTER, INTENT(IN) :: TRANSB -INTEGER(KIND=JPIM) :: M -INTEGER(KIND=JPIM) :: N -INTEGER(KIND=JPIM) :: K -REAL(KIND=JPRM) :: ALPHA -REAL(KIND=JPRM), DIMENSION(:,:,:) :: AARRAY -INTEGER(KIND=JPIM) :: LDA -INTEGER(KIND=JPIM) :: STRIDEA -REAL(KIND=JPRM), DIMENSION(:,:,:) :: BARRAY -INTEGER(KIND=JPIM) :: LDB -INTEGER(KIND=JPIM) :: STRIDEB -REAL(KIND=JPRM) :: BETA -REAL(KIND=JPRM), DIMENSION(:,:,:) :: CARRAY -INTEGER(KIND=JPIM) :: LDC -INTEGER(KIND=JPIM) :: STRIDEC -INTEGER(KIND=JPIM) :: BATCHCOUNT - -CALL CUDA_SGEMM_BATCHED( & - & TRANSA, TRANSB, & - & M, N, K, & - & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & - & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) -END SUBROUTINE CUDA_SGEMM_BATCHED_OVERLOAD + INTERFACE + SUBROUTINE CUDA_SGEMM_BATCHED(& + & CTA, CTB, & + & M, N, K, & + & ALPHA, & + & A, LDA, TDA, & + & B, LDB, TDB, & + & BETA, & + & C, LDC, TDC, & + & BATCHCOUNT, STREAM & + &) BIND(C, NAME='cublas_sgemm_wrapper') + USE ISO_C_BINDING + INTEGER(C_INT), VALUE :: CTA, CTB, M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT + REAL(C_FLOAT), VALUE :: ALPHA,BETA + REAL(C_FLOAT) :: A(*), B(*), C(*) + INTEGER(KIND=c_size_t) :: STREAM + END SUBROUTINE CUDA_SGEMM_BATCHED + SUBROUTINE CUDA_DGEMM_BATCHED(& + & CTA, CTB, & + & M, N, K, & + & ALPHA, & + & A, LDA, TDA, & + & B, LDB, TDB, & + & BETA, & + & C, LDC, TDC, & + & BATCHCOUNT, STREAM & + &) BIND(C, NAME='cublas_dgemm_wrapper') + USE ISO_C_BINDING + INTEGER(C_INT), VALUE :: CTA, CTB, M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT + REAL(C_DOUBLE), VALUE :: ALPHA,BETA + REAL(C_DOUBLE) :: A(*), B(*), C(*) + INTEGER(KIND=c_size_t) :: STREAM + END SUBROUTINE CUDA_DGEMM_BATCHED + SUBROUTINE CUDA_DGEMM_GROUPED(& + & BLAS_ID, CTA, CTB, & + & M, N, K, & + & ALPHA, & + & A, LDA, OFFSETA, & + & B, LDB, OFFSETB, & + & BETA, & + & C, LDC, OFFSETC, & + & BATCHCOUNT, STREAM & + &) BIND(C, NAME='blas_dgemm_wrapper_grouped') + USE ISO_C_BINDING + INTEGER(C_INT), VALUE :: BLAS_ID, CTA, CTB, M, N(:), K(:), LDA, LDB, LDC, OFFSETA(:), OFFSETB(:), OFFSETC(:), BATCHCOUNT + REAL(C_DOUBLE), VALUE :: ALPHA,BETA + REAL(C_DOUBLE) :: A(*), B(*), C(*) + INTEGER(KIND=c_size_t) :: STREAM + END SUBROUTINE CUDA_DGEMM_GROUPED + SUBROUTINE CUDA_SGEMM_GROUPED(& + & BLAS_ID, CTA, CTB, & + & M, N, K, & + & ALPHA, & + & A, LDA, OFFSETA, & + & B, LDB, OFFSETB, & + & BETA, & + & C, LDC, OFFSETC, & + & BATCHCOUNT, STREAM & + &) BIND(C, NAME='blas_sgemm_wrapper_grouped') + USE ISO_C_BINDING + INTEGER(C_INT), VALUE :: BLAS_ID, CTA, CTB, M, N(:), K(:), LDA, LDB, LDC, OFFSETA(:), OFFSETB(:), OFFSETC(:), BATCHCOUNT + REAL(C_FLOAT), VALUE :: ALPHA,BETA + REAL(C_FLOAT) :: A(*), B(*), C(*) + INTEGER(KIND=c_size_t) :: STREAM + END SUBROUTINE CUDA_SGEMM_GROUPED + END INTERFACE -SUBROUTINE CUDA_SGEMM_STRIDED_BATCHED_OVERLOAD( & - & TRANSA, TRANSB, & - & M, N, K, & - & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & - & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - CHARACTER, INTENT(IN) :: TRANSA - CHARACTER, INTENT(IN) :: TRANSB - INTEGER(KIND=JPIM) :: M - INTEGER(KIND=JPIM) :: N - INTEGER(KIND=JPIM) :: K - REAL(KIND=JPRM) :: ALPHA - REAL(KIND=JPRM), DIMENSION(:,:,:) :: AARRAY - INTEGER(KIND=JPIM) :: LDA - INTEGER(KIND=JPIB) :: STRIDEA - REAL(KIND=JPRM), DIMENSION(:,:,:) :: BARRAY - INTEGER(KIND=JPIM) :: LDB - INTEGER(KIND=JPIB) :: STRIDEB - REAL(KIND=JPRM) :: BETA - REAL(KIND=JPRM), DIMENSION(:,:,:) :: CARRAY - INTEGER(KIND=JPIM) :: LDC - INTEGER(KIND=JPIB) :: STRIDEC - INTEGER(KIND=JPIM) :: BATCHCOUNT - - CALL CUDA_SGEMM_STRIDED_BATCHED( & - & TRANSA, TRANSB, & - & M, N, K, & - & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & - & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) -END SUBROUTINE CUDA_SGEMM_STRIDED_BATCHED_OVERLOAD +CONTAINS -SUBROUTINE CUDA_DGEMM_BATCHED_1D_OVERLOAD( & +SUBROUTINE CUDA_DGEMM_BATCHED_OVERLOAD( & & TRANSA, TRANSB, & & M, N, K, & & ALPHA, & @@ -139,9 +101,9 @@ SUBROUTINE CUDA_DGEMM_BATCHED_1D_OVERLOAD( & & BARRAY, LDB, STRIDEB, & & BETA, & & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - CHARACTER, INTENT(IN) :: TRANSA - CHARACTER, INTENT(IN) :: TRANSB + & BATCHCOUNT, STREAM) + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSA + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSB INTEGER(KIND=JPIM) :: M INTEGER(KIND=JPIM) :: N INTEGER(KIND=JPIM) :: K @@ -149,7 +111,7 @@ SUBROUTINE CUDA_DGEMM_BATCHED_1D_OVERLOAD( & REAL(KIND=JPRD), DIMENSION(:) :: AARRAY INTEGER(KIND=JPIM) :: LDA INTEGER(KIND=JPIM) :: STRIDEA - REAL(KIND=JPRD), DIMENSION(:,:,:) :: BARRAY + REAL(KIND=JPRD), DIMENSION(*) :: BARRAY INTEGER(KIND=JPIM) :: LDB INTEGER(KIND=JPIM) :: STRIDEB REAL(KIND=JPRD) :: BETA @@ -157,7 +119,9 @@ SUBROUTINE CUDA_DGEMM_BATCHED_1D_OVERLOAD( & INTEGER(KIND=JPIM) :: LDC INTEGER(KIND=JPIM) :: STRIDEC INTEGER(KIND=JPIM) :: BATCHCOUNT + INTEGER(KIND=C_LONG) :: STREAM + !$ACC HOST_DATA USE_DEVICE(AARRAY,BARRAY,CARRAY) CALL CUDA_DGEMM_BATCHED( & & TRANSA, TRANSB, & & M, N, K, & @@ -166,10 +130,11 @@ SUBROUTINE CUDA_DGEMM_BATCHED_1D_OVERLOAD( & & BARRAY, LDB, STRIDEB, & & BETA, & & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - END SUBROUTINE CUDA_DGEMM_BATCHED_1D_OVERLOAD + & BATCHCOUNT, ACC_GET_CUDA_STREAM(STREAM)) + !$ACC END HOST_DATA + END SUBROUTINE CUDA_DGEMM_BATCHED_OVERLOAD - SUBROUTINE CUDA_SGEMM_BATCHED_1D_OVERLOAD( & + SUBROUTINE CUDA_SGEMM_BATCHED_OVERLOAD( & & TRANSA, TRANSB, & & M, N, K, & & ALPHA, & @@ -177,9 +142,9 @@ SUBROUTINE CUDA_SGEMM_BATCHED_1D_OVERLOAD( & & BARRAY, LDB, STRIDEB, & & BETA, & & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - CHARACTER, INTENT(IN) :: TRANSA - CHARACTER, INTENT(IN) :: TRANSB + & BATCHCOUNT, STREAM) + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSA + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSB INTEGER(KIND=JPIM) :: M INTEGER(KIND=JPIM) :: N INTEGER(KIND=JPIM) :: K @@ -187,7 +152,7 @@ SUBROUTINE CUDA_SGEMM_BATCHED_1D_OVERLOAD( & REAL(KIND=JPRM), DIMENSION(:) :: AARRAY INTEGER(KIND=JPIM) :: LDA INTEGER(KIND=JPIM) :: STRIDEA - REAL(KIND=JPRM), DIMENSION(:,:,:) :: BARRAY + REAL(KIND=JPRM), DIMENSION(*) :: BARRAY INTEGER(KIND=JPIM) :: LDB INTEGER(KIND=JPIM) :: STRIDEB REAL(KIND=JPRM) :: BETA @@ -195,7 +160,9 @@ SUBROUTINE CUDA_SGEMM_BATCHED_1D_OVERLOAD( & INTEGER(KIND=JPIM) :: LDC INTEGER(KIND=JPIM) :: STRIDEC INTEGER(KIND=JPIM) :: BATCHCOUNT + INTEGER(KIND=C_LONG) :: STREAM + !$ACC HOST_DATA USE_DEVICE(AARRAY,BARRAY,CARRAY) CALL CUDA_SGEMM_BATCHED( & & TRANSA, TRANSB, & & M, N, K, & @@ -204,45 +171,92 @@ SUBROUTINE CUDA_SGEMM_BATCHED_1D_OVERLOAD( & & BARRAY, LDB, STRIDEB, & & BETA, & & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - END SUBROUTINE CUDA_SGEMM_BATCHED_1D_OVERLOAD - - SUBROUTINE CUDA_SGEMM_STRIDED_BATCHED_1D_OVERLOAD( & - & TRANSA, TRANSB, & + & BATCHCOUNT, ACC_GET_CUDA_STREAM(STREAM)) + !$ACC END HOST_DATA + END SUBROUTINE CUDA_SGEMM_BATCHED_OVERLOAD + + SUBROUTINE CUDA_DGEMM_GROUPED_OVERLOAD( & + & BLAS_ID, TRANSA, TRANSB, & & M, N, K, & & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & + & AARRAY, LDA, OFFSETA, & + & BARRAY, LDB, OFFSETB, & & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - CHARACTER, INTENT(IN) :: TRANSA - CHARACTER, INTENT(IN) :: TRANSB + & CARRAY, LDC, OFFSETC, & + & BATCHCOUNT, STREAM) + INTEGER(KIND=C_INT), INTENT(IN) :: BLAS_ID + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSA + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSB INTEGER(KIND=JPIM) :: M - INTEGER(KIND=JPIM) :: N - INTEGER(KIND=JPIM) :: K + INTEGER(KIND=JPIM) :: N(:) + INTEGER(KIND=JPIM) :: K(:) + REAL(KIND=JPRD) :: ALPHA + REAL(KIND=JPRD), DIMENSION(:) :: AARRAY + INTEGER(KIND=JPIM) :: LDA + INTEGER(KIND=JPIM) :: OFFSETA(:) + REAL(KIND=JPRD), DIMENSION(*) :: BARRAY + INTEGER(KIND=JPIM) :: LDB + INTEGER(KIND=JPIM) :: OFFSETB(:) + REAL(KIND=JPRD) :: BETA + REAL(KIND=JPRD), DIMENSION(:) :: CARRAY + INTEGER(KIND=JPIM) :: LDC + INTEGER(KIND=JPIM) :: OFFSETC(:) + INTEGER(KIND=JPIM) :: BATCHCOUNT + INTEGER(KIND=C_LONG) :: STREAM + + !$ACC HOST_DATA USE_DEVICE(AARRAY,BARRAY,CARRAY) + CALL CUDA_DGEMM_GROUPED( & + & BLAS_ID, TRANSA, TRANSB, & + & M, N, K, & + & ALPHA, & + & AARRAY, LDA, OFFSETA, & + & BARRAY, LDB, OFFSETB, & + & BETA, & + & CARRAY, LDC, OFFSETC, & + & BATCHCOUNT, ACC_GET_CUDA_STREAM(STREAM)) + !$ACC END HOST_DATA + END SUBROUTINE CUDA_DGEMM_GROUPED_OVERLOAD + + SUBROUTINE CUDA_SGEMM_GROUPED_OVERLOAD( & + & BLAS_ID, TRANSA, TRANSB, & + & M, N, K, & + & ALPHA, & + & AARRAY, LDA, OFFSETA, & + & BARRAY, LDB, OFFSETB, & + & BETA, & + & CARRAY, LDC, OFFSETC, & + & BATCHCOUNT, STREAM) + INTEGER(KIND=C_INT), INTENT(IN) :: BLAS_ID + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSA + INTEGER(KIND=C_INT), INTENT(IN) :: TRANSB + INTEGER(KIND=JPIM) :: M + INTEGER(KIND=JPIM) :: N(:) + INTEGER(KIND=JPIM) :: K(:) REAL(KIND=JPRM) :: ALPHA REAL(KIND=JPRM), DIMENSION(:) :: AARRAY INTEGER(KIND=JPIM) :: LDA - INTEGER(KIND=JPIB) :: STRIDEA - REAL(KIND=JPRM), DIMENSION(:,:,:) :: BARRAY + INTEGER(KIND=JPIM) :: OFFSETA(:) + REAL(KIND=JPRM), DIMENSION(*) :: BARRAY INTEGER(KIND=JPIM) :: LDB - INTEGER(KIND=JPIB) :: STRIDEB + INTEGER(KIND=JPIM) :: OFFSETB(:) REAL(KIND=JPRM) :: BETA REAL(KIND=JPRM), DIMENSION(:) :: CARRAY INTEGER(KIND=JPIM) :: LDC - INTEGER(KIND=JPIB) :: STRIDEC + INTEGER(KIND=JPIM) :: OFFSETC(:) INTEGER(KIND=JPIM) :: BATCHCOUNT + INTEGER(KIND=C_LONG) :: STREAM - CALL CUDA_SGEMM_STRIDED_BATCHED( & - & TRANSA, TRANSB, & + !$ACC HOST_DATA USE_DEVICE(AARRAY,BARRAY,CARRAY) + CALL CUDA_SGEMM_GROUPED( & + & BLAS_ID, TRANSA, TRANSB, & & M, N, K, & & ALPHA, & - & AARRAY, LDA, STRIDEA, & - & BARRAY, LDB, STRIDEB, & + & AARRAY, LDA, OFFSETA, & + & BARRAY, LDB, OFFSETB, & & BETA, & - & CARRAY, LDC, STRIDEC, & - & BATCHCOUNT) - END SUBROUTINE CUDA_SGEMM_STRIDED_BATCHED_1D_OVERLOAD + & CARRAY, LDC, OFFSETC, & + & BATCHCOUNT, ACC_GET_CUDA_STREAM(STREAM)) + !$ACC END HOST_DATA + END SUBROUTINE CUDA_SGEMM_GROUPED_OVERLOAD END MODULE CUDA_GEMM_BATCHED_MOD diff --git a/src/trans/gpu/internal/dir_trans_ctl_mod.F90 b/src/trans/gpu/internal/dir_trans_ctl_mod.F90 index d175ccde6..0355fe889 100755 --- a/src/trans/gpu/internal/dir_trans_ctl_mod.F90 +++ b/src/trans/gpu/internal/dir_trans_ctl_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2001- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -9,214 +10,175 @@ MODULE DIR_TRANS_CTL_MOD CONTAINS -SUBROUTINE DIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& - & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& - & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) - -!**** *DIR_TRANS_CTL* - Control routine for direct spectral transform. - -! Purpose. -! -------- -! Control routine for the direct spectral transform - -!** Interface. -! ---------- -! CALL DIR_TRANS_CTL(...) - -! Explicit arguments : -! -------------------- -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! PSPVOR(:,:) - spectral vorticity -! PSPDIV(:,:) - spectral divergence -! PSPSCALAR(:,:) - spectral scalarvalued fields -! KVSETUV(:) - indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. -! KVESETSC(:) - indicating which 'b-set' in spectral space owns a -! scalar field. As for KVSETUV this argument is required -! if the total number of processors is greater than -! the number of processors used for distribution in -! spectral wave space. -! PGP(:,:,:) - gridpoint fields - -! The ordering of the output fields is as follows (all -! parts are optional depending on the input switches): -! -! u : KF_UV_G fields -! v : KF_UV_G fields -! scalar fields : KF_SCALARS_G fields + SUBROUTINE DIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) + + !**** *DIR_TRANS_CTL* - Control routine for direct spectral transform. + + ! Purpose. + ! -------- + ! Control routine for the direct spectral transform + + !** Interface. + ! ---------- + ! CALL DIR_TRANS_CTL(...) + + ! Explicit arguments : + ! -------------------- + ! KF_UV_G - global number of spectral u-v fields + ! KF_SCALARS_G - global number of scalar spectral fields + ! KF_GP - total number of output gridpoint fields + ! KF_FS - total number of fields in fourier space + ! KF_UV - local number of spectral u-v fields + ! KF_SCALARS - local number of scalar spectral fields + ! PSPVOR(:,:) - spectral vorticity + ! PSPDIV(:,:) - spectral divergence + ! PSPSCALAR(:,:) - spectral scalarvalued fields + ! KVSETUV(:) - indicating which 'b-set' in spectral space owns a + ! vor/div field. Equivalant to NBSETLEV in the IFS. + ! The length of KVSETUV should be the GLOBAL number + ! of u/v fields which is the dimension of u and v releated + ! fields in grid-point space. + ! KVESETSC(:) - indicating which 'b-set' in spectral space owns a + ! scalar field. As for KVSETUV this argument is required + ! if the total number of processors is greater than + ! the number of processors used for distribution in + ! spectral wave space. + ! PGP(:,:,:) - gridpoint fields + + ! The ordering of the output fields is as follows (all + ! parts are optional depending on the input switches): + ! + ! u : KF_UV_G fields + ! v : KF_UV_G fields + ! scalar fields : KF_SCALARS_G fields + + ! Method. + ! ------- + + ! Externals. SHUFFLE - reshuffle fields for load balancing + ! ---------- FIELD_SPLIT - split fields in NPROMATR packets + ! LTDIR_CTL - control of Legendre transform + ! FTDIR_CTL - control of Fourier transform + + ! Author. + ! ------- + ! Mats Hamrud *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 01-01-03 + + ! ------------------------------------------------------------------ + + USE PARKIND_ECTRANS ,ONLY : JPRBT, JPRD, JPRB, JPIM + + USE TPM_GEN ,ONLY : NPROMATR, NOUT + USE TPM_DISTR, ONLY: NPROC + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_TRANS, ONLY: REUSE_PTR + USE TPM_GEN + USE ALLOCATOR_MOD + + USE FTDIR_MOD + USE LTDIR_MOD + USE TRGTOL_MOD + USE TRLTOM_MOD + USE TRLTOM_PACK_UNPACK + + IMPLICIT NONE + + ! Declaration of arguments + + INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G + INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G + INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV + INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPUV(:,:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3A(:,:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3B(:,:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP2(:,:,:) + + ! Local variables + + INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) + INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) + INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) + INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G + INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP + INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB + + REAL(KIND=JPRBT), POINTER :: FOUBUF_IN(:), FOUBUF(:) + REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:), PREEL_COMPLEX(:) + + REAL(KIND=JPRBT), POINTER :: ZINPS(:), ZINPA(:) + REAL(KIND=JPRD), POINTER :: ZINPS0(:), ZINPA0(:) + + TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR + TYPE(TRGTOL_HANDLE) :: HTRGTOL + TYPE(FTDIR_HANDLE) :: HFTDIR + TYPE(TRLTOM_PACK_HANDLE) :: HTRLTOM_PACK + TYPE(TRLTOM_HANDLE) :: HTRLTOM + TYPE(TRLTOM_UNPACK_HANDLE) :: HTRLTOM_UNPACK + TYPE(LTDIR_HANDLE) :: HLTDIR + + IF(NPROMATR > 0) THEN + PRINT *, "ERROR, not implemented right now (NPROMATR > 0)" + STOP 4 + ENDIF -! Method. -! ------- + ! Prepare everything + ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() + HTRGTOL = PREPARE_TRGTOL(ALLOCATOR,KF_GP,KF_FS) + HFTDIR = PREPARE_FTDIR() + HTRLTOM_PACK = PREPARE_TRLTOM_PACK(ALLOCATOR, KF_FS) + HTRLTOM = PREPARE_TRLTOM(ALLOCATOR, KF_FS) + HTRLTOM_UNPACK = PREPARE_TRLTOM_UNPACK(ALLOCATOR, KF_FS) + HLTDIR = PREPARE_LTDIR(ALLOCATOR, KF_FS, KF_UV) -! Externals. SHUFFLE - reshuffle fields for load balancing -! ---------- FIELD_SPLIT - split fields in NPROMATR packets -! LTDIR_CTL - control of Legendre transform -! FTDIR_CTL - control of Fourier transform + CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, REUSE_PTR) -! Author. -! ------- -! Mats Hamrud *ECMWF* + ! from the PGP arrays to PREEL_REAL + CALL TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& + & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& + & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& + & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) -! Modifications. -! -------------- -! Original : 01-01-03 + IF (KF_FS > 0) THEN -! ------------------------------------------------------------------ + ! fourier transform from PREEL_REAL to PREEL_COMPLEX (in-place!) + CALL GSTATS(1640,0) + CALL FTDIR(HFTDIR,PREEL_REAL,PREEL_COMPLEX,KF_FS) + CALL GSTATS(1640,1) -USE PARKIND1 ,ONLY : JPIM ,JPRB + CALL GSTATS(153,0) -USE TPM_GEN ,ONLY : NPROMATR -USE TPM_TRANS ,ONLY : FOUBUF_IN, NF_SC2, NF_SC3A, NF_SC3B -!USE TPM_DISTR + WRITE(NOUT,*) 'ltdir_ctl:TRLTOM_CUDAAWARE' + CALL TRLTOM_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) + CALL TRLTOM_CUDAAWARE(ALLOCATOR,HTRLTOM,FOUBUF_IN,FOUBUF,KF_FS) + CALL TRLTOM_UNPACK(ALLOCATOR,HTRLTOM_UNPACK,FOUBUF,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV) + CALL GSTATS(153,1) -USE SHUFFLE_MOD ,ONLY : SHUFFLE -USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT -USE LTDIR_CTL_MOD ,ONLY : LTDIR_CTL -USE FTDIR_CTL_MOD ,ONLY : FTDIR_CTL -USE TPM_TRANS ,ONLY : ZGTF -use nvtx -! + CALL LTDIR(ALLOCATOR,HLTDIR,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV,KF_SCALARS, & + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2) -IMPLICIT NONE - -! Declaration of arguments - -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP -INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP2(:,:,:) - -! Local variables - -INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) -INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) -INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) -INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G -INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP -INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB - - -! ------------------------------------------------------------------ - -! Perform transform - -!$ACC KERNELS -ZGTF(:,:) = 0 -!$ACC END KERNELS - -IF_GPB = 2*KF_UV_G+KF_SCALARS_G -IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN - - ! Fields to be split into packets - - CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& - & KVSETUV,KVSETSC) - - IBLKS=(IF_GPB-1)/NPROMATR+1 - - DO JBLK=1,IBLKS - - CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& - & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& - & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) - - IF_FS = 2*IF_UV + IF_SCALARS - IF_GP = 2*IF_UV_G+IF_SCALARS_G - DO JFLD=1,IF_UV_G - IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) - IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) - ENDDO - DO JFLD=1,IF_SCALARS_G - IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) - ENDDO - DO JFLD=1,IF_UV - IPTRSPUV(JFLD) = ISTUV+JFLD-1 - ENDDO - DO JFLD=1,IF_SCALARS - IPTRSPSC(JFLD) = ISTSC+JFLD-1 - ENDDO - - IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN - CALL FTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) - ELSEIF(IF_UV_G > 0) THEN - CALL FTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KPTRGP=IPTRGP,PGP=PGP) - ELSEIF(IF_SCALARS_G > 0) THEN - CALL FTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) ENDIF - !$ACC DATA COPYIN(FOUBUF_IN) - CALL LTDIR_CTL(IF_FS,IF_UV,IF_SCALARS, & - & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC) - !$ACC END DATA - - ENDDO -ELSE - - ! No splitting of fields, transform done in one go - call nvtxStartRange("DIRTRANS_nodata") - - !$ACC DATA CREATE(FOUBUF_IN) - call nvtxStartRange("FTDIR") - CALL FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,& - & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& - & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& - & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) - call nvtxEndRange - - call nvtxStartRange("LTDIR") - !$ACC DATA COPYOUT(PSPVOR,PSPDIV) IF(KF_UV > 0) - !$ACC DATA COPYOUT(PSPSCALAR) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSCALAR)) - !$ACC DATA COPYOUT(PSPSC2) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSC2) .AND. NF_SC2 > 0) - !$ACC DATA COPYOUT(PSPSC3A) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSC3A) .AND. NF_SC3A > 0) - !$ACC DATA COPYOUT(PSPSC3B) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSC3B) .AND. NF_SC3B > 0) - CALL LTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & - & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2) - call nvtxEndRange - CALL GSTATS(430,0) - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - CALL GSTATS(430,1) - call nvtxEndRange - -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE DIR_TRANS_CTL + + END SUBROUTINE DIR_TRANS_CTL END MODULE DIR_TRANS_CTL_MOD diff --git a/src/trans/gpu/internal/dir_trans_ctlad_mod.F90 b/src/trans/gpu/internal/dir_trans_ctlad_mod.F90 deleted file mode 100755 index b78148979..000000000 --- a/src/trans/gpu/internal/dir_trans_ctlad_mod.F90 +++ /dev/null @@ -1,193 +0,0 @@ -! (C) Copyright 2001- 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 DIR_TRANS_CTLAD_MOD -CONTAINS -SUBROUTINE DIR_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& - & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& - & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) - -!**** *DIR_TRANS_CTLAD* - Control routine for direct spectral transform-adj. - -! Purpose. -! -------- -! Control routine for the direct spectral transform - -!** Interface. -! ---------- -! CALL DIR_TRANS_CTLAD(...) - -! Explicit arguments : -! -------------------- -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! PSPVOR(:,:) - spectral vorticity -! PSPDIV(:,:) - spectral divergence -! PSPSCALAR(:,:) - spectral scalarvalued fields -! KVSETUV(:) - indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. -! KVESETSC(:) - indicating which 'b-set' in spectral space owns a -! scalar field. As for KVSETUV this argument is required -! if the total number of processors is greater than -! the number of processors used for distribution in -! spectral wave space. -! PGP(:,:,:) - gridpoint fields - -! The ordering of the output fields is as follows (all -! parts are optional depending on the input switches): - -! u : KF_UV_G fields -! v : KF_UV_G fields -! scalar fields : KF_SCALARS_G fields - -! Method. -! ------- - -! Externals. SHUFFLE - reshuffle fields for load balancing -! ---------- FIELD_SPLIT - split fields in NPROMATR packets -! LTDIR_CTLAD - control of Legendre transform -! FTDIR_CTLAD - control of Fourier transform - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 01-01-03 - -! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB -USE TPM_GEN ,ONLY : NPROMATR -!USE TPM_TRANS -!USE TPM_DISTR - -USE SHUFFLE_MOD ,ONLY : SHUFFLE -USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT -USE LTDIR_CTLAD_MOD ,ONLY : LTDIR_CTLAD -USE FTDIR_CTLAD_MOD ,ONLY : FTDIR_CTLAD -! - -IMPLICIT NONE - -! Declaration of arguments - -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP -INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) - -! Local variables - -INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) -INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) -INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) -INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G -INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP -INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB - - -! ------------------------------------------------------------------ - -! Perform transform - -IF_GPB = 2*KF_UV_G+KF_SCALARS_G -IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN - - ! Fields to be split into packets - - CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& - & KVSETUV,KVSETSC) - - IBLKS=(IF_GPB-1)/NPROMATR+1 - - DO JBLK=1,IBLKS - - CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& - & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& - & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) - - IF_FS = 2*IF_UV + IF_SCALARS - IF_GP = 2*IF_UV_G+IF_SCALARS_G - DO JFLD=1,IF_UV_G - IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) - IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) - ENDDO - DO JFLD=1,IF_SCALARS_G - IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) - ENDDO - DO JFLD=1,IF_UV - IPTRSPUV(JFLD) = ISTUV+JFLD-1 - ENDDO - DO JFLD=1,IF_SCALARS - IPTRSPSC(JFLD) = ISTSC+JFLD-1 - ENDDO - - CALL LTDIR_CTLAD(IF_FS,IF_UV,IF_SCALARS, & - & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC) - IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN - CALL FTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) - ELSEIF(IF_UV_G > 0) THEN - CALL FTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KPTRGP=IPTRGP,PGP=PGP) - ELSEIF(IF_SCALARS_G > 0) THEN - CALL FTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) - ENDIF - ENDDO - -ELSE - - ! No splitting of fields, transform done in one go - - CALL LTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & - &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2) - - CALL FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,& - & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& - & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& - & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) - -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE DIR_TRANS_CTLAD -END MODULE DIR_TRANS_CTLAD_MOD diff --git a/src/trans/gpu/internal/ext_acc.F90 b/src/trans/gpu/internal/ext_acc.F90 new file mode 100644 index 000000000..8beaa0172 --- /dev/null +++ b/src/trans/gpu/internal/ext_acc.F90 @@ -0,0 +1,387 @@ +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 openacc_ext_type + use iso_c_binding + implicit none + private + public :: ext_acc_arr_desc + + ! to my knowledge, this cannot be part of openacc_ext + type ext_acc_arr_desc + integer(c_size_t) :: ptr, sz + end type +end module +module openacc_ext + use iso_c_binding + use openacc + use openacc_ext_type + implicit none + + private + public :: ext_acc_pass, ext_acc_create, ext_acc_copyin, ext_acc_copyout, & + & ext_acc_delete, ext_acc_arr_desc, acc_handle_kind + + type common_pointer_descr + type(c_ptr) :: ptr + integer(c_size_t) :: sz + end type + + interface ext_acc_pass + function ext_acc_pass_2d_r4(arr) result(ret) + use openacc_ext_type + implicit none + type(ext_acc_arr_desc) :: ret + real(4), intent(in) :: arr(:,:) + end function + function ext_acc_pass_3d_r4(arr) result(ret) + use openacc_ext_type + implicit none + type(ext_acc_arr_desc) :: ret + real(4), intent(in) :: arr(:,:,:) + end function + function ext_acc_pass_4d_r4(arr) result(ret) + use openacc_ext_type + implicit none + type(ext_acc_arr_desc) :: ret + real(4), intent(in) :: arr(:,:,:,:) + end function + function ext_acc_pass_2d_r8(arr) result(ret) + use openacc_ext_type + implicit none + type(ext_acc_arr_desc) :: ret + real(8), intent(in) :: arr(:,:) + end function + function ext_acc_pass_3d_r8(arr) result(ret) + use openacc_ext_type + implicit none + type(ext_acc_arr_desc) :: ret + real(8), intent(in) :: arr(:,:,:) + end function + function ext_acc_pass_4d_r8(arr) result(ret) + use openacc_ext_type + implicit none + type(ext_acc_arr_desc) :: ret + real(8), intent(in) :: arr(:,:,:,:) + end function + end interface +contains + + function ext_acc_pass_2d_r4(arr) result(ret) + implicit none + type(ext_acc_arr_desc) :: ret + real(4), intent(in) :: arr(:,:) + + type(c_ptr) :: ptr1, ptr2 + integer(c_size_t) :: ptr1_v, ptr2_v + + ! get full slices for all but the last slice + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1)) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + + ret%ptr = ptr1_v + ret%sz = (ptr2_v - ptr1_v) * (size(arr, 2) - 1) + + ! for the last slice, take the actual offset, otherwise we imght go OOB + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) + ptr2 = c_loc(arr(lbound(arr,1)+1, lbound(arr,2))) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 1) + end function + function ext_acc_pass_3d_r4(arr) result(ret) + implicit none + type(ext_acc_arr_desc) :: ret + real(4), intent(in) :: arr(:,:,:) + + type(c_ptr) :: ptr1, ptr2 + integer(c_size_t) :: ptr1_v, ptr2_v + + ! get full slices for all but the last slice + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3)+1)) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + + ret%ptr = ptr1_v + ret%sz = (ptr2_v - ptr1_v) * (size(arr, 3) - 1) + + ! for the last slice, take the actual offset, otherwise we imght go OOB + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1, lbound(arr,3))) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 2) + end function + function ext_acc_pass_4d_r4(arr) result(ret) + implicit none + type(ext_acc_arr_desc) :: ret + real(4), intent(in) :: arr(:,:,:,:) + + type(c_ptr) :: ptr1, ptr2 + integer(c_size_t) :: ptr1_v, ptr2_v + + ! get full slices for all but the last slice + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4)+1)) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + + ret%ptr = ptr1_v + ret%sz = (ptr2_v - ptr1_v) * (size(arr, 4) - 1) + + ! for the last slice, take the actual offset, otherwise we imght go OOB + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3)+1, lbound(arr,4))) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 3) + end function + function ext_acc_pass_2d_r8(arr) result(ret) + implicit none + type(ext_acc_arr_desc) :: ret + real(8), intent(in) :: arr(:,:) + + type(c_ptr) :: ptr1, ptr2 + integer(c_size_t) :: ptr1_v, ptr2_v + + ! get full slices for all but the last slice + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1)) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + + ret%ptr = ptr1_v + ret%sz = (ptr2_v - ptr1_v) * (size(arr, 2) - 1) + + ! for the last slice, take the actual offset, otherwise we imght go OOB + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) + ptr2 = c_loc(arr(lbound(arr,1)+1, lbound(arr,2))) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 1) + end function + function ext_acc_pass_3d_r8(arr) result(ret) + implicit none + type(ext_acc_arr_desc) :: ret + real(8), intent(in) :: arr(:,:,:) + + type(c_ptr) :: ptr1, ptr2 + integer(c_size_t) :: ptr1_v, ptr2_v + + ! get full slices for all but the last slice + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3)+1)) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + + ret%ptr = ptr1_v + ret%sz = (ptr2_v - ptr1_v) * (size(arr, 3) - 1) + + ! for the last slice, take the actual offset, otherwise we imght go OOB + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1, lbound(arr,3))) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 2) + end function + function ext_acc_pass_4d_r8(arr) result(ret) + implicit none + type(ext_acc_arr_desc) :: ret + real(8), intent(in) :: arr(:,:,:,:) + + type(c_ptr) :: ptr1, ptr2 + integer(c_size_t) :: ptr1_v, ptr2_v + + ! get full slices for all but the last slice + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4)+1)) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + + ret%ptr = ptr1_v + ret%sz = (ptr2_v - ptr1_v) * (size(arr, 4) - 1) + + ! for the last slice, take the actual offset, otherwise we imght go OOB + ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) + ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3)+1, lbound(arr,4))) + ptr1_v= transfer(ptr1, ptr1_v) + ptr2_v= transfer(ptr2, ptr2_v) + ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 3) + end function + function get_common_pointers(in_ptrs, out_ptrs) result(num_ranges) + implicit none + type(ext_acc_arr_desc), intent(in) :: in_ptrs(:) + type(common_pointer_descr), intent(out) :: out_ptrs(:) + + integer(c_size_t), allocatable :: ptrs_only(:) + logical, allocatable :: mask(:) + integer, allocatable :: sort_index(:) + + type(ext_acc_arr_desc), allocatable :: common_ptrs(:) + integer :: i, j, num_ranges + integer(c_size_t) :: start1, start2, end1, end2 + logical :: found + + ! first sort the pointers increasingly such that no gaps are possible + allocate(ptrs_only(size(in_ptrs))) + do i = 1, size(in_ptrs) + ptrs_only(i) = in_ptrs(i)%ptr + enddo + allocate(mask(size(in_ptrs))) + do i = 1, size(in_ptrs) + mask(i) = .true. + enddo + allocate(sort_index(size(in_ptrs))) + do i = 1, size(in_ptrs) + j = minloc(ptrs_only, 1, mask=mask) + mask(j) = .false. + sort_index(i) = j + enddo + + ! initialize + allocate(common_ptrs(size(in_ptrs))) + do i = 1, size(in_ptrs) + common_ptrs(1)%ptr = 0 + common_ptrs(1)%sz = 0 + enddo + + num_ranges = 1 + common_ptrs(1) = in_ptrs(sort_index(1)) + do i = 2, size(in_ptrs) + found = .false. + start1 = in_ptrs(sort_index(i))%ptr + end1 = in_ptrs(sort_index(i))%ptr + in_ptrs(sort_index(i))%sz + do j = 1, num_ranges + start2 = common_ptrs(j)%ptr + end2 = common_ptrs(j)%ptr + common_ptrs(j)%sz + if (max(start1, start2) <= min(end1, end2)) then + ! if we intersect with this range, extend the range + common_ptrs(j)%ptr = min(start1, start2) + common_ptrs(j)%sz = max(end1, end2) - common_ptrs(j)%ptr + found = .true. + exit + endif + enddo + if (.not. found) then + ! if we did not find anything: add a new one + num_ranges = num_ranges + 1 + common_ptrs(num_ranges)%ptr = start1 + common_ptrs(num_ranges)%sz = end1 - start1 + endif + enddo + do i = 1, num_ranges + out_ptrs(i)%ptr = transfer(common_ptrs(i)%ptr, out_ptrs(i)%ptr) + out_ptrs(i)%sz = common_ptrs(i)%sz + enddo + end function + subroutine ext_acc_create(ptrs, stream) + use openacc + implicit none + type(ext_acc_arr_desc), intent(in) :: ptrs(:) + integer(acc_handle_kind), optional :: stream + + type(common_pointer_descr), allocatable :: common_ptrs(:) + + integer :: i, num_ranges + integer(4), pointer :: pp(:) + integer(acc_handle_kind) :: stream_act + + if (present(stream)) then + stream_act = stream + else + stream_act = acc_async_sync + endif + allocate(common_ptrs(size(ptrs))) + num_ranges = get_common_pointers(ptrs, common_ptrs) + + do i = 1, num_ranges + call c_f_pointer(common_ptrs(i)%ptr, pp, shape=[common_ptrs(i)%sz/sizeof(pp(1))]) + call acc_create_async(pp, common_ptrs(i)%sz, async=stream_act) + enddo + end subroutine + subroutine ext_acc_copyin(ptrs, stream) + use openacc + implicit none + type(ext_acc_arr_desc), intent(in) :: ptrs(:) + integer(acc_handle_kind), optional :: stream + + type(common_pointer_descr), allocatable :: common_ptrs(:) + + integer :: i, num_ranges + integer(4), pointer :: pp(:) + + integer(acc_handle_kind) :: stream_act + + if (present(stream)) then + stream_act = stream + else + stream_act = acc_async_sync + endif + allocate(common_ptrs(size(ptrs))) + num_ranges = get_common_pointers(ptrs, common_ptrs) + + do i = 1, num_ranges + call c_f_pointer(common_ptrs(i)%ptr, pp, shape=[common_ptrs(i)%sz/sizeof(pp(1))]) + call acc_copyin_async(pp, common_ptrs(i)%sz, async=stream_act) + enddo + end subroutine + subroutine ext_acc_copyout(ptrs, stream) + use openacc + implicit none + type(ext_acc_arr_desc), intent(in) :: ptrs(:) + integer(acc_handle_kind), optional :: stream + + type(common_pointer_descr), allocatable :: common_ptrs(:) + + integer :: i, num_ranges + integer(4), pointer :: pp(:) + + integer(acc_handle_kind) :: stream_act + + if (present(stream)) then + stream_act = stream + else + stream_act = acc_async_sync + endif + allocate(common_ptrs(size(ptrs))) + num_ranges = get_common_pointers(ptrs, common_ptrs) + + do i = 1, num_ranges + call c_f_pointer(common_ptrs(i)%ptr, pp, shape=[common_ptrs(i)%sz/sizeof(pp(1))]) + call acc_copyout_async(pp, common_ptrs(i)%sz, async=stream_act) + enddo + end subroutine + subroutine ext_acc_delete(ptrs, stream) + use openacc + implicit none + type(ext_acc_arr_desc), intent(in) :: ptrs(:) + integer(acc_handle_kind), optional :: stream + + type(common_pointer_descr), allocatable :: common_ptrs(:) + + integer :: i, num_ranges + integer(4), pointer :: pp(:) + + integer(acc_handle_kind) :: stream_act + + if (present(stream)) then + stream_act = stream + else + stream_act = acc_async_sync + endif + allocate(common_ptrs(size(ptrs))) + num_ranges = get_common_pointers(ptrs, common_ptrs) + + do i = 1, num_ranges + call c_f_pointer(common_ptrs(i)%ptr, pp, shape=[common_ptrs(i)%sz/sizeof(pp(1))]) + call acc_delete_async(pp, common_ptrs(i)%sz, async=stream_act) + enddo + end subroutine +end module diff --git a/src/trans/gpu/internal/fourier_in_mod.F90 b/src/trans/gpu/internal/fourier_in_mod.F90 deleted file mode 100755 index efe1d68bc..000000000 --- a/src/trans/gpu/internal/fourier_in_mod.F90 +++ /dev/null @@ -1,127 +0,0 @@ -! (C) Copyright 2000- 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 FOURIER_IN_MOD -CONTAINS -SUBROUTINE FOURIER_IN(PREEL,KFIELDS) - -!**** *FOURIER_IN* - Copy fourier data from buffer to local array - -! Purpose. -! -------- -! Routine for copying fourier data from buffer to local array - -!** Interface. -! ---------- -! CALL FOURIER_IN(...) - -! Explicit arguments : PREEL - local fourier/GP array -! -------------------- KFIELDS - number of fields -! -! Externals. None. -! ---------- - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 2000-04-01 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC, D_NSTAGTF,D_MSTABF,D_NSTAGT0B,D_NPNTGTB0,D_NPROCM,D_NPTRLS -USE TPM_TRANS ,ONLY : FOUBUF -USE TPM_GEOMETRY ,ONLY : G, G_NMEN,G_NMEN_MAX -use tpm_gen, only: nout -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS - -INTEGER(KIND=JPIM) :: KGL - -REAL(KIND=JPRBT), INTENT(OUT) :: PREEL(:,:) - -INTEGER(KIND=JPIM) :: JM,JF,IGLG,IPROC,IR,II,ISTA -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC,iimax1,iimax2,iimax3,iunit - -! ------------------------------------------------------------------ - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -!$ACC DATA PRESENT(D_NPTRLS,G_NMEN,D_NPROCM,D_NSTAGT0B,D_MSTABF,D_NPNTGTB0,FOUBUF,PREEL,D_NSTAGTF) -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IGLG,IPROC,ISTA) DEFAULT(NONE) -DO KGL=IBEG,IEND,IINC - DO JM=0,G_NMEN_MAX - DO JF=1,KFIELDS - - IGLG = D_NPTRLS(MYSETW)+KGL-1 - - if ( JM .le. G_NMEN(IGLG)) then - - IPROC = D_NPROCM(JM) - ISTA = (D_NSTAGT0B(D_MSTABF(IPROC))+D_NPNTGTB0(JM,KGL))*2*KFIELDS - - PREEL(2*JF-1,2*JM+1+D_NSTAGTF(KGL)) = FOUBUF(ISTA+2*JF-1) - PREEL(2*JF, 2*JM+1+D_NSTAGTF(KGL)) = FOUBUF(ISTA+2*JF ) - !write(nout,*) , 'istart1 ...', KGL, JM, JF, ISTA+2*JF,ISTA,D_NSTAGT0B(D_MSTABF(IPROC)),IPROC,KFIELDS - !write(nout,*) , 'istart2 ...',D_NPNTGTB0(JM,KGL), FOUBUF(ISTA+2*JF-1), FOUBUF(ISTA+2*JF),2*JM+1+D_NSTAGTF(KGL) - !if(jf==1 .and. 2*JM+1+D_NSTAGTF(KGL)==7972) write(nout,*) 'fourier_in: fidx=7972, kgl=',kgl,' jm=',jm - !TODO (Andreas): should be able to remove the factor 2 in the second dimension (in front of jm) - !and reduce the size of the array. Will need to adapt fsc_mod accordingly! This is actually more - !difficult: d_nstagtf(kgl) is not necessarily even! - - end if - ENDDO - ENDDO -ENDDO -!$ACC END DATA - -!iimax1=0 -!iimax2=0 -!iimax3=0 -!iunit=myproc+300 -!DO KGL=IBEG,IEND,IINC -! DO JM=0,G_NMEN_MAX -! DO JF=1,KFIELDS -! -! IGLG = D_NPTRLS(MYSETW)+KGL-1 -! -! if ( JM .le. G_NMEN(IGLG)) then -! -! IPROC = D_NPROCM(JM) -! ISTA = (D_NSTAGT0B(D_MSTABF(IPROC))+D_NPNTGTB0(JM,KGL))*2*KFIELDS -! -! iimax1=max(iimax1,2*JF) -! iimax2=max(iimax2,2*JM+1+D_NSTAGTF(KGL)) -! iimax3=max(iimax3,ISTA+2*JF) -! -! endif -! ENDDO -! ENDDO -!ENDDO -!write(iunit,*) 'max_in ',iimax1,size(PREEL,1),iimax2,size(PREEL,2),iimax3,size(FOUBUF) -! ------------------------------------------------------------------ - -END SUBROUTINE FOURIER_IN -END MODULE FOURIER_IN_MOD - diff --git a/src/trans/gpu/internal/fourier_inad_mod.F90 b/src/trans/gpu/internal/fourier_inad_mod.F90 deleted file mode 100755 index 4d5a0945e..000000000 --- a/src/trans/gpu/internal/fourier_inad_mod.F90 +++ /dev/null @@ -1,73 +0,0 @@ -! (C) Copyright 2000- 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 FOURIER_INAD_MOD -CONTAINS -SUBROUTINE FOURIER_INAD(PREEL,KFIELDS,KGL) - -!**** *FOURIER_INAD* - Copy fourier data from buffer to local array - adjoint - -! Purpose. -! -------- -! Routine for copying fourier data from buffer to local array - -!** Interface. -! ---------- -! CALL FOURIER_INAD(...) - -! Explicit arguments : PREEL - local fourier/GP array -! -------------------- KFIELDS - number of fields -! -! Externals. None. -! ---------- - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 2000-04-01 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW -USE TPM_TRANS ,ONLY : FOUBUF -USE TPM_GEOMETRY ,ONLY : G -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL - -REAL(KIND=JPRBT), INTENT(IN) :: PREEL(:,:) - -INTEGER(KIND=JPIM) :: JM,JF,IGLG,IPROC,IR,II,ISTA - -! ------------------------------------------------------------------ - -IGLG = D%NPTRLS(MYSETW)+KGL-1 -DO JM=0,G%NMEN(IGLG) - IPROC = D%NPROCM(JM) - IR = 2*JM+1+D%NSTAGTF(KGL) - II = 2*JM+2+D%NSTAGTF(KGL) - ISTA = (D%NSTAGT0B(D%MSTABF(IPROC))+D%NPNTGTB0(JM,KGL))*2*KFIELDS - DO JF=1,KFIELDS - FOUBUF(ISTA+2*JF-1) = PREEL(JF,IR) - FOUBUF(ISTA+2*JF ) = PREEL(JF,II) - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE FOURIER_INAD -END MODULE FOURIER_INAD_MOD - diff --git a/src/trans/gpu/internal/fourier_out_mod.F90 b/src/trans/gpu/internal/fourier_out_mod.F90 deleted file mode 100755 index 1617406f8..000000000 --- a/src/trans/gpu/internal/fourier_out_mod.F90 +++ /dev/null @@ -1,129 +0,0 @@ -! (C) Copyright 2000- 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 FOURIER_OUT_MOD -CONTAINS -SUBROUTINE FOURIER_OUT(KFIELDS) - -!**** *FOURIER_OUT* - Copy fourier data from local array to buffer - -! Purpose. -! -------- -! Routine for copying fourier data from local array to buffer - -!** Interface. -! ---------- -! CALL FOURIER_OUT(...) - -! Explicit arguments : PREEL - local fourier/GP array -! -------------------- KFIELDS - number of fields -! -! Externals. None. -! ---------- - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 2000-04-01 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC, D_NPTRLS,D_NSTAGTF,D_MSTABF,D_NSTAGT1B,D_NPNTGTB0,D_NPROCM, D_NPROCL -USE TPM_TRANS ,ONLY : FOUBUF_IN, ZGTF -USE TPM_GEOMETRY ,ONLY : G, G_NMEN,G_NMEN_MAX -! - -IMPLICIT NONE - -!REAL(KIND=JPRBT), INTENT(IN) :: PREEL(:,:) -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS -INTEGER(KIND=JPIM) :: KGL - -INTEGER(KIND=JPIM) :: JM,JF,IGLG,IPROC,IR,II,ISTA, ISTA1,JMMAX, iunit - -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC, IOFF,iimax1,iimax2,iimax3 - -! ------------------------------------------------------------------ - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -!$ACC DATA PRESENT(FOUBUF_IN,ZGTF, D_NPTRLS,G_NMEN,D_NPROCM,D_NSTAGT1B,D_MSTABF,D_NPNTGTB0,D_NSTAGTF) COPYIN(IBEG,IEND,IINC) -!$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(IGLG,JMMAX,IPROC,ISTA,IOFF) -DO KGL=IBEG,IEND,IINC - DO JM=0,G_NMEN_MAX - DO JF=1,KFIELDS - - IGLG = D_NPTRLS(MYSETW)+KGL-1 - JMMAX = G_NMEN(IGLG) - if (JM .le. JMMAX) then - - IPROC = D_NPROCM(JM) - ISTA = (D_NSTAGT1B(D_MSTABF(IPROC))+D_NPNTGTB0(JM,KGL))*2*KFIELDS - IOFF = 1+D_NSTAGTF(KGL) - - ! imaginary may be not JM+1 but JM+G_NMEN(IGLG)+1 - FOUBUF_IN(ISTA+2*JF-1) = ZGTF(2*JF-1, 2*JM+IOFF) - FOUBUF_IN(ISTA+2*JF ) = ZGTF(2*JF , 2*JM+IOFF) - !if( myproc.eq.1 .and. jf.eq.1 .and. JM.eq.0 ) write(*,*) 'fou_oD ',ISTA+2*JF-1,FOUBUF_IN(ISTA+2*JF-1),FOUBUF_IN(ISTA+2*JF ) - !if( myproc.eq.1 .and. jf.eq.1 .and. JM.eq.0 ) write(*,*) 'fou_oD1 ', ZGTF(JF, 2*JM+IOFF), ZGTF(JF, 2*JM+1+IOFF) - !if( myproc.eq.2 .and. jf.eq.1 .and. JM.eq.0 ) write(*,*) 'fou_oD ',ISTA+2*JF-1,FOUBUF_IN(ISTA+2*JF-1),FOUBUF_IN(ISTA+2*JF ) - !if( myproc.eq.2 .and. jf.eq.1 .and. JM.eq.0 ) write(*,*) 'fou_oD1 ', IOFF, KGL, ZGTF(JF, 2*JM+IOFF), ZGTF(JF, 2*JM+1+IOFF) - - end if - ENDDO - ENDDO -END DO -!$ACC END DATA - -!iimax1=0 -!iimax2=0 -!iimax3=0 -!iunit=myproc+300 -!DO KGL=IBEG,IEND,IINC -! DO JM=0,G_NMEN_MAX -! DO JF=1,KFIELDS -! IGLG = D_NPTRLS(MYSETW)+KGL-1 -! JMMAX = G_NMEN(IGLG) -! if (JM .le. JMMAX) then -! IPROC = D_NPROCM(JM) -! ISTA = (D_NSTAGT1B(D_MSTABF(IPROC))+D_NPNTGTB0(JM,KGL))*2*KFIELDS -! IOFF = 1+D_NSTAGTF(KGL) -! iimax1 = max(iimax1,2*JF) -! iimax2 = max(iimax2,2*JM+IOFF) -! iimax3 = max(iimax3,ISTA+2*JF) -! !if( jf.eq.(41+137-1) .and. JM.eq.0 ) write(iunit,*) 'fou_o ',ISTA+2*JF-1,FOUBUF_IN(ISTA+2*JF-1),FOUBUF_IN(ISTA+2*JF ) -! if( jf.eq.1 .and. JM.eq.0 ) write(iunit,*) 'fou_o10 ', IOFF, KGL, ZGTF(2*JF-1, 2*JM+IOFF), ZGTF(2*JF, 2*JM+IOFF) -! !if( jf.eq.1 .and. JM.eq.1 ) write(iunit,*) 'fou_o11 ', IOFF, KGL, ZGTF(JF, 2*JM+IOFF), ZGTF(JF, 2*JM+1+IOFF) -! !if( jf.eq.1 .and. JM.eq.2 ) write(iunit,*) 'fou_o12 ', IOFF, KGL, ZGTF(JF, 2*JM+IOFF), ZGTF(JF, 2*JM+1+IOFF) -! !if( jf.eq.1 ) write(iunit,*) 'fou_o2 ', IOFF, ZGTF(JF, 2*JM-1+IOFF),ZGTF(JF, 2*JM+IOFF),ZGTF(JF, 2*JM+1+IOFF) - ! end if -! -! ENDDO -! ENDDO -!ENDDO -!write(iunit,*), 'maxes ',iimax1,size(ZGTF,1),iimax2,size(ZGTF,2),iimax3,size(FOUBUF_IN) - -! ------------------------------------------------------------------ - -END SUBROUTINE FOURIER_OUT -END MODULE FOURIER_OUT_MOD - diff --git a/src/trans/gpu/internal/fourier_outad_mod.F90 b/src/trans/gpu/internal/fourier_outad_mod.F90 deleted file mode 100755 index f87540e05..000000000 --- a/src/trans/gpu/internal/fourier_outad_mod.F90 +++ /dev/null @@ -1,72 +0,0 @@ -! (C) Copyright 2000- 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 FOURIER_OUTAD_MOD -CONTAINS -SUBROUTINE FOURIER_OUTAD(PREEL,KFIELDS,KGL) - -!**** *FOURIER_OUTAD* - Copy fourier data from local array to buffer - adjoint - -! Purpose. -! -------- -! Routine for copying fourier data from local array to buffer - -!** Interface. -! ---------- -! CALL FOURIER_OUTAD(...) - -! Explicit arguments : PREEL - local fourier/GP array -! -------------------- KFIELDS - number of fields -! -! Externals. None. -! ---------- - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 2000-04-01 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW -USE TPM_TRANS ,ONLY : FOUBUF_IN -USE TPM_GEOMETRY ,ONLY : G -! - -IMPLICIT NONE - -REAL(KIND=JPRBT), INTENT(OUT) :: PREEL(:,:) -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL - -INTEGER(KIND=JPIM) :: JM,JF,IGLG,IPROC,IR,II,ISTA - -! ------------------------------------------------------------------ - -IGLG = D%NPTRLS(MYSETW)+KGL-1 -DO JM=0,G%NMEN(IGLG) - IPROC = D%NPROCM(JM) - IR = 2*JM+1+D%NSTAGTF(KGL) - II = 2*JM+2+D%NSTAGTF(KGL) - ISTA = (D%NSTAGT1B(D%MSTABF(IPROC))+D%NPNTGTB0(JM,KGL))*2*KFIELDS - DO JF=1,KFIELDS - PREEL(JF,IR) = FOUBUF_IN(ISTA+2*JF-1) - PREEL(JF,II) = FOUBUF_IN(ISTA+2*JF ) - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE FOURIER_OUTAD -END MODULE FOURIER_OUTAD_MOD - diff --git a/src/trans/gpu/internal/fsc_mod.F90 b/src/trans/gpu/internal/fsc_mod.F90 index 5040840af..3047a8b3a 100755 --- a/src/trans/gpu/internal/fsc_mod.F90 +++ b/src/trans/gpu/internal/fsc_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,9 +9,27 @@ ! MODULE FSC_MOD + USE ALLOCATOR_MOD + IMPLICIT NONE + + PRIVATE + PUBLIC :: FSC, PREPARE_FSC, FSC_HANDLE + + TYPE FSC_HANDLE + END TYPE + CONTAINS -SUBROUTINE FSC(KF_UV,KF_SCALARS,KF_SCDERS,& - & KST_UV,KST_SC,KST_NSDERS,KST_EWDERS,KST_UVDERS) + FUNCTION PREPARE_FSC(ALLOCATOR) RESULT(HFSC) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + TYPE(FSC_HANDLE) :: HFSC + END FUNCTION +SUBROUTINE FSC(ALLOCATOR,HFSC,PREEL_COMPLEX, KF_FS, KF_UV, KF_SCALARS, KUV_OFFSET, & + & KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET) !**** *FSC - Division by a*cos(theta), east-west derivatives @@ -24,11 +43,11 @@ SUBROUTINE FSC(KF_UV,KF_SCALARS,KF_SCDERS,& !** Interface. ! ---------- ! CALL FSC(..) -! Explicit arguments : PUV - u and v -! -------------------- PSCALAR - scalar valued varaibles -! PNSDERS - N-S derivative of S.V.V. -! PEWDERS - E-W derivative of S.V.V. -! PUVDERS - E-W derivative of u and v +! Explicit arguments : KF_FS - total stride +! -------------------- KF_UV - # uv layers +! KF_SCALARS - # scalar layers +! *_OFFSET - offset of the respective layer +! ! Method. ! ------- @@ -46,37 +65,32 @@ SUBROUTINE FSC(KF_UV,KF_SCALARS,KF_SCDERS,& ! ------------------------------------------------------------------ USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_TRANS ,ONLY : LUVDER, LATLON, ZGTF -USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC +USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC, D_NSTAGTF +USE TPM_GEOMETRY ,ONLY : G, G_NMEN, G_NLOEN, G_NLOEN_MAX USE TPM_FIELDS ,ONLY : F -USE TPM_GEOMETRY ,ONLY : G USE TPM_FLT ,ONLY: S -use tpm_gen, only: nout +USE TPM_GEN, ONLY: NOUT +USE TPM_DIM, ONLY: R_NSMAX + +USE TPM_TRANS ,ONLY : LATLON ! IMPLICIT NONE -INTEGER(KIND=JPIM) :: KGL -INTEGER(KIND=JPIM) , INTENT(IN) :: KF_UV,KF_SCALARS,KF_SCDERS -INTEGER(KIND=JPIM) , INTENT(IN) :: KST_UV, KST_SC, KST_NSDERS, KST_EWDERS, KST_UVDERS -REAL(KIND=JPRBT) , POINTER :: PUV(:,:) -REAL(KIND=JPRBT) , POINTER :: PSCALAR(:,:) -REAL(KIND=JPRBT) , POINTER :: PNSDERS(:,:) -REAL(KIND=JPRBT) , POINTER :: PEWDERS(:,:) -REAL(KIND=JPRBT) , POINTER :: PUVDERS(:,:) - -REAL(KIND=JPRBT) :: ZACHTE,ZMUL, ZACHTE2, ZSHIFT, ZPI -REAL(KIND=JPRBT) :: ZAMP, ZPHASE -INTEGER(KIND=JPIM) :: IMEN,ISTAGTF - - -INTEGER(KIND=JPIM) :: JLON,JF,IGLG,II,IR,JM +INTEGER(KIND=JPIM) :: KGL +REAL(KIND=JPRBT) :: ZACHTE2 +INTEGER(KIND=JPIM) :: IOFF_LAT,OFFSET_VAR +INTEGER(KIND=JPIM) :: IOFF_SCALARS,IOFF_SCALARS_EWDER,IOFF_UV,IOFF_UV_EWDER,IOFF_KSCALARS_NSDER +INTEGER(KIND=JPIM) :: JF,IGLG,JM INTEGER(KIND=JPIM) :: IBEG,IEND,IINC -!DEBUGGING: -integer :: i,J,maxi,maxj -real :: maxv +REAL(KIND=JPRBT) :: RET_REAL, RET_COMPLEX + +REAL(KIND=JPRBT), INTENT(INOUT) :: PREEL_COMPLEX(:) +INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV, KF_SCALARS +INTEGER(KIND=JPIM), INTENT(IN) :: KUV_OFFSET, KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(FSC_HANDLE), INTENT(IN) :: HFSC ! ------------------------------------------------------------------ @@ -90,144 +104,142 @@ SUBROUTINE FSC(KF_UV,KF_SCALARS,KF_SCDERS,& IINC=-1 ENDIF -!write(301,*) ' nums ', KST_UV, KST_SC, KF_UV, KST_nsders, KST_ewders, KF_SCDERS, KST_uvders, D%NDGL_FS -IF( KF_UV > 0 ) THEN - PUV => ZGTF(2*KST_UV-1:2*(KST_UV+2*KF_UV-1),:) -ENDIF -PSCALAR => ZGTF(2*KST_SC-1:2*(KST_SC+KF_SCALARS-1),:) -IF( KF_SCDERS > 0 ) THEN - PNSDERS => ZGTF(2*KST_nsders-1:2*(KST_nsders+KF_SCDERS-1),:) - PEWDERS => ZGTF(2*KST_ewders-1:2*(KST_ewders+KF_SCDERS-1),:) -ENDIF -IF (LUVDER) THEN - PUVDERS => ZGTF(2*KST_uvders-1:2*(KST_uvders+2*KF_UV-1),:) -ENDIF - -!$ACC DATA PRESENT(ZGTF) & -!$ACC& PRESENT(PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) +!$ACC DATA PRESENT(D,G,F,D_NSTAGTF,G_NMEN,G_NLOEN,PREEL_COMPLEX) -DO KGL=IBEG,IEND,IINC - -IGLG = D%NPTRLS(MYSETW)+KGL-1 -ZACHTE = F%RACTHE(IGLG) -IMEN = G%NMEN(IGLG) -ISTAGTF = D%NSTAGTF(KGL) -ZACHTE2 = F%RACTHE(IGLG) - -IF( LATLON.AND.S%LDLL ) THEN - ZPI = 2.0_JPRBT*ASIN(1.0_JPRBT) - ZACHTE2 = 1._JPRBT - ZACHTE = F%RACTHE2(IGLG) - - ! apply shift for (even) lat-lon output grid - IF( S%LSHIFTLL ) THEN - ZSHIFT = ZPI/REAL(G%NLOEN(IGLG),JPRBT) - - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IR,II,ZAMP,ZPHASE) - DO JF=1,KF_SCALARS - DO JM=0,IMEN - IR = ISTAGTF+2*JM+1 - II = IR+1 - - ! calculate amplitude and add phase shift then reconstruct A,B - ZAMP = SQRT(PSCALAR(JF,IR)**2 + PSCALAR(JF,II)**2) - ZPHASE = ATAN2(PSCALAR(JF,II),PSCALAR(JF,IR)) + REAL(JM,JPRBT)*ZSHIFT - - PSCALAR(2*JF-1,IR) = ZAMP*COS(ZPHASE) - PSCALAR(2*JF, Ir) = ZAMP*SIN(ZPHASE) - ENDDO - ENDDO - IF(KF_SCDERS > 0)THEN - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IR,II,ZAMP,ZPHASE) - DO JF=1,KF_SCALARS - DO JM=0,IMEN - IR = ISTAGTF+2*JM+1 - II = IR+1 - ! calculate amplitude and phase shift and reconstruct A,B - ZAMP = SQRT(PNSDERS(JF,IR)**2 + PNSDERS(JF,II)**2) - ZPHASE = ATAN2(PNSDERS(JF,II),PNSDERS(JF,IR)) + REAL(JM,JPRBT)*ZSHIFT - PNSDERS(2*JF-1,IR) = ZAMP*COS(ZPHASE) - PNSDERS(2*JF, Ir) = ZAMP*SIN(ZPHASE) - ENDDO - ENDDO - ENDIF - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IR,II,ZAMP,ZPHASE) - DO JF=1,2*KF_UV - DO JM=0,IMEN - IR = ISTAGTF+2*JM+1 - II = IR+1 - ! calculate amplitude and phase shift and reconstruct A,B - ZAMP = SQRT(PUV(JF,IR)**2 + PUV(JF,II)**2) - ZPHASE = ATAN2(PUV(JF,II),PUV(JF,IR)) + REAL(JM,JPRBT)*ZSHIFT - PUV(2*JF-1,IR) = ZAMP*COS(ZPHASE) - PUV(2*JF, Ir) = ZAMP*SIN(ZPHASE) - ENDDO - ENDDO - ENDIF +IF( LATLON.AND.S%LDLL.AND.S%LSHIFTLL ) THEN + PRINT *, "This is not implemented yet! LATLON.AND.S%LDLL.AND.S%LSHIFTLL" + STOP 128 ! not implemented ENDIF - - ! ------------------------------------------------------------------ - + +OFFSET_VAR=D%NPTRLS(MYSETW) + !* 1. DIVIDE U V AND N-S DERIVATIVES BY A*COS(THETA) ! ---------------------------------------------- - !* 1.1 U AND V. -IF(KF_UV > 0) THEN - !$ACC PARALLEL LOOP DEFAULT(NONE) - DO JLON=ISTAGTF+1,ISTAGTF+2*IMEN+1 - DO JF=1,2*KF_UV - PUV(2*JF-1,JLON) = PUV(2*JF-1,JLON)*ZACHTE2 - PUV(2*JF, JLON) = PUV(2*JF ,JLON)*ZACHTE2 +!$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) ASYNC(1) +DO KGL=IBEG,IEND,IINC + DO JF=1,2*KF_UV + DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) + IGLG = OFFSET_VAR+KGL-1 + IF (JM <= G_NMEN(IGLG)) THEN + IOFF_LAT = KF_FS*D_NSTAGTF(KGL) + IOFF_UV = IOFF_LAT+(KUV_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + + ZACHTE2 = F%RACTHE(IGLG) + + PREEL_COMPLEX(IOFF_UV+2*JM+1) = & + & PREEL_COMPLEX(IOFF_UV+2*JM+1)*ZACHTE2 + PREEL_COMPLEX(IOFF_UV+2*JM+2) = & + & PREEL_COMPLEX(IOFF_UV+2*JM+2)*ZACHTE2 + ENDIF ENDDO ENDDO -ENDIF +ENDDO !* 1.2 N-S DERIVATIVES -IF(KF_SCDERS > 0)THEN - !$ACC PARALLEL LOOP DEFAULT(NONE) - DO JLON=ISTAGTF+1,ISTAGTF+2*IMEN+1 +IF (KSCALARS_NSDER_OFFSET >= 0) THEN + !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) ASYNC(1) + DO KGL=IBEG,IEND,IINC DO JF=1,KF_SCALARS - PNSDERS(2*JF-1,JLON) = PNSDERS(2*JF-1,JLON)*ZACHTE2 - PNSDERS(2*JF, JLON) = PNSDERS(2*JF, JLON)*ZACHTE2 + DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) + IGLG = OFFSET_VAR+KGL-1 + IF (JM <= G_NMEN(IGLG)) THEN + IOFF_LAT = KF_FS*D_NSTAGTF(KGL) + IOFF_KSCALARS_NSDER = IOFF_LAT+(KSCALARS_NSDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + + ZACHTE2 = F%RACTHE(IGLG) + + PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+1) = & + & PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+1)*ZACHTE2 + PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+2) = & + & PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+2)*ZACHTE2 + ENDIF + ENDDO ENDDO ENDDO ENDIF -! ------------------------------------------------------------------ + ! ------------------------------------------------------------------ !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. -IF(LUVDER)THEN - !$ACC PARALLEL LOOP PRIVATE(IR) DEFAULT(NONE) - DO JM=0,IMEN +IF (KUV_EWDER_OFFSET >= 0) THEN + !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) ASYNC(1) + DO KGL=IBEG,IEND,IINC DO JF=1,2*KF_UV - IR = ISTAGTF+2*JM+1 - PUVDERS(2*JF-1,IR) = -PUV(2*JF,IR)*ZACHTE2*REAL(JM,JPRBT) - PUVDERS(2*JF, IR) = PUV(2*JF-1,IR)*ZACHTE2*REAL(JM,JPRBT) + DO JM=0,G_NLOEN_MAX/2 + IGLG = OFFSET_VAR+KGL-1 + ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have + ! to fill those floor(NLON/2)+1 values. + ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. + IF (JM <= G_NLOEN(IGLG)/2) THEN + IOFF_LAT = KF_FS*D_NSTAGTF(KGL) + IOFF_UV = IOFF_LAT+(KUV_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + IOFF_UV_EWDER = IOFF_LAT+(KUV_EWDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + + RET_REAL = 0.0_JPRBT + RET_COMPLEX = 0.0_JPRBT + + IF (JM <= G_NMEN(IGLG)) THEN + ZACHTE2 = F%RACTHE(IGLG) + + RET_REAL = & + & -PREEL_COMPLEX(IOFF_UV+2*JM+2)*ZACHTE2*REAL(JM,JPRBT) + RET_COMPLEX = & + & PREEL_COMPLEX(IOFF_UV+2*JM+1)*ZACHTE2*REAL(JM,JPRBT) + ENDIF + PREEL_COMPLEX(IOFF_UV_EWDER+2*JM+1) = RET_REAL + PREEL_COMPLEX(IOFF_UV_EWDER+2*JM+2) = RET_COMPLEX + ENDIF + ENDDO ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES - -IF(KF_SCDERS > 0)THEN - !$ACC PARALLEL LOOP PRIVATE(IR) DEFAULT(NONE) - DO JM=0,IMEN +IF (KSCALARS_EWDER_OFFSET > 0) THEN + !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) ASYNC(1) & + !$ACC& PRIVATE(IGLG,IOFF_LAT,IOFF_SCALARS_EWDER,IOFF_SCALARS,ZACHTE2) + DO KGL=IBEG,IEND,IINC DO JF=1,KF_SCALARS - IR = ISTAGTF+2*JM+1 - PEWDERS(2*JF-1,IR) = -PSCALAR(2*JF,IR)*ZACHTE2*REAL(JM,JPRBT) - PEWDERS(2*JF, IR) = PSCALAR(2*JF-1,IR)*ZACHTE2*REAL(JM,JPRBT) + DO JM=0,G_NLOEN_MAX/2 + IGLG = OFFSET_VAR+KGL-1 + ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have + ! to fill those floor(NLON/2)+1 values. + ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. + IF (JM <= G_NLOEN(IGLG)/2) THEN + IOFF_LAT = KF_FS*D_NSTAGTF(KGL) + IOFF_SCALARS_EWDER = IOFF_LAT+(KSCALARS_EWDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + IOFF_SCALARS = IOFF_LAT+(KSCALARS_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + + RET_REAL = 0.0_JPRBT + RET_COMPLEX = 0.0_JPRBT + + IF (JM <= G_NMEN(IGLG)) THEN + ZACHTE2 = F%RACTHE(IGLG) + + RET_REAL = & + & -PREEL_COMPLEX(IOFF_SCALARS+2*JM+2)*ZACHTE2*REAL(JM,JPRBT) + RET_COMPLEX = & + & PREEL_COMPLEX(IOFF_SCALARS+2*JM+1)*ZACHTE2*REAL(JM,JPRBT) + ENDIF + ! The rest from G_NMEN(IGLG+1)...MAX is zero truncated + PREEL_COMPLEX(IOFF_SCALARS_EWDER+2*JM+1) = RET_REAL + PREEL_COMPLEX(IOFF_SCALARS_EWDER+2*JM+2) = RET_COMPLEX + ENDIF + ENDDO ENDDO ENDDO ENDIF -enddo +!$ACC WAIT(1) + !$ACC END DATA ! ------------------------------------------------------------------ diff --git a/src/trans/gpu/internal/fscad_mod.F90 b/src/trans/gpu/internal/fscad_mod.F90 deleted file mode 100755 index 098381fcb..000000000 --- a/src/trans/gpu/internal/fscad_mod.F90 +++ /dev/null @@ -1,145 +0,0 @@ -! (C) Copyright 2000- 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 FSCAD_MOD -CONTAINS -SUBROUTINE FSCAD(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& - & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) - -!**** *FSCAD - Division by a*cos(theta), east-west derivatives - adjoint - -! Purpose. -! -------- -! In Fourier space divide u and v and all north-south -! derivatives by a*cos(theta). Also compute east-west derivatives -! of u,v,thermodynamic, passiv scalar variables and surface -! pressure. - -!** Interface. -! ---------- -! CALL FSCAD(..) -! Explicit arguments : PUV - u and v -! -------------------- PSCALAR - scalar valued varaibles -! PNSDERS - N-S derivative of S.V.V. -! PEWDERS - E-W derivative of S.V.V. -! PUVDERS - E-W derivative of u and v -! Method. -! ------- - -! Externals. None. -! ---------- - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 (From SC2FSC) - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_TRANS ,ONLY : LUVDER -USE TPM_DISTR ,ONLY : D, MYSETW -USE TPM_FIELDS ,ONLY : F -USE TPM_GEOMETRY ,ONLY : G -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS -REAL(KIND=JPRBT) , INTENT(INOUT) :: PUV(:,:) -REAL(KIND=JPRBT) , INTENT(INOUT) :: PSCALAR(:,:) -REAL(KIND=JPRBT) , INTENT(INOUT) :: PNSDERS(:,:) -REAL(KIND=JPRBT) , INTENT(INOUT) :: PEWDERS(:,:) -REAL(KIND=JPRBT) , INTENT(INOUT) :: PUVDERS(:,:) - -REAL(KIND=JPRBT) :: ZACHTE,ZMUL -INTEGER(KIND=JPIM) :: IMEN,ISTAGTF - - -INTEGER(KIND=JPIM) :: JLON,JF,IGLG,II,IR,JM - -! ------------------------------------------------------------------ - -IGLG = D%NPTRLS(MYSETW)+KGL-1 -ZACHTE = F%RACTHE(IGLG) -IMEN = G%NMEN(IGLG) -ISTAGTF = D%NSTAGTF(KGL) - - -! ------------------------------------------------------------------ - -!* 2. EAST-WEST DERIVATIVES -! --------------------- - -!* 2.1 U AND V. - -IF(LUVDER)THEN - DO JM=0,IMEN - IR = ISTAGTF+2*JM+1 - II = IR+1 - ZMUL = ZACHTE*JM - DO JF=1,2*KF_UV - PUV(JF,II) = PUV(JF,II) - PUVDERS(JF,IR)*ZMUL - PUV(JF,IR) = PUV(JF,IR) + PUVDERS(JF,II)*ZMUL -! PUVDERS(JF,IR) = _ZERO_ -! PUVDERS(JF,II) = _ZERO_ - ENDDO - ENDDO -ENDIF - -!* 2.2 SCALAR VARIABLES - -IF(KF_SCDERS > 0)THEN - DO JM=0,IMEN - IR = ISTAGTF+2*JM+1 - II = IR+1 - ZMUL = ZACHTE*JM - DO JF=1,KF_SCALARS - PSCALAR(JF,II) = PSCALAR(JF,II) - PEWDERS(JF,IR)*ZMUL - PSCALAR(JF,IR) = PSCALAR(JF,IR) + PEWDERS(JF,II)*ZMUL -! PEWDERS(JF,IR) = _ZERO_ -! PEWDERS(JF,II) = _ZERO_ - ENDDO - ENDDO -ENDIF - -! ------------------------------------------------------------------ - -!* 1. DIVIDE U V AND N-S DERIVATIVES BY A*COS(THETA) -! ---------------------------------------------- - - -!* 1.1 U AND V. - -IF(KF_UV > 0) THEN - DO JLON=ISTAGTF+1,ISTAGTF+2*(IMEN+1) - DO JF=1,2*KF_UV - PUV(JF,JLON) = PUV(JF,JLON)*ZACHTE - ENDDO - ENDDO -ENDIF - -!* 1.2 N-S DERIVATIVES - -IF(KF_SCDERS > 0)THEN - DO JLON=ISTAGTF+1,ISTAGTF+2*(IMEN+1) - DO JF=1,KF_SCALARS - PNSDERS(JF,JLON) = PNSDERS(JF,JLON)*ZACHTE - ENDDO - ENDDO -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE FSCAD -END MODULE FSCAD_MOD diff --git a/src/trans/gpu/internal/fspgl_int_mod.F90 b/src/trans/gpu/internal/fspgl_int_mod.F90 deleted file mode 100755 index 651655b10..000000000 --- a/src/trans/gpu/internal/fspgl_int_mod.F90 +++ /dev/null @@ -1,123 +0,0 @@ -! (C) Copyright 2000- 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 FSPGL_INT_MOD -CONTAINS -SUBROUTINE FSPGL_INT(KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,& - & FSPGL_PROC,KFLDPTRUV,KFLDPTRSC) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_TRANS ,ONLY : FOUBUF_IN, LDIVGP, LVORGP -USE TPM_GEOMETRY ,ONLY : G -USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS,D_NASM0 -USE TPM_FIELDS ,ONLY : F -USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM) :: KM, KMLOC -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT -EXTERNAL FSPGL_PROC -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - -! -! ZFIELD 2nd dimension is extended from 0 to R%NDGL+1, while only 1 to R%NDGL -! is given from the north/south transforms, and only 1 to R%NDGL rows will be -! passed to the east/west transforms. -! the 2 extra rows are used inside the model Fourier space computations -! (outside the transform package - see FSPGLH in Arpege/IFS). -! -REAL(KIND=JPRBT) :: ZFIELD(2*KF_OUT_LT,0:R%NDGL+1) - - -INTEGER(KIND=JPIM) :: ISL, IGLS, JFLD, JGL ,IPROC, IPROCS -INTEGER(KIND=JPIM) :: IPTRU,IST,J -INTEGER(KIND=JPIM) :: IDGNH,IDGL -INTEGER(KIND=JPIM) :: ISTAN(R%NDGNH),ISTAS(R%NDGNH) -INTEGER(KIND=JPIM) :: IFLDPTRUV(KF_UV),IFLDPTRSC(KF_SCALARS) -! ------------------------------------------------------------------ -!$acc data if(present(KFLDPTRUV)) COPYIN(KFLDPTRUV,KFLDPTRSC) -!$acc data create(IFLDPTRUV,IFLDPTRSC,ISTAN,ISTAS,ZFIELD) & -!$acc& present(d_myms,D%NSTAGT0B,D%NPNTGTB1,D%NPROCL,FOUBUF_IN) -IF(PRESENT(KFLDPTRUV)) THEN - IFLDPTRUV(:) = KFLDPTRUV(1:KF_UV) - IFLDPTRSC(:) = KFLDPTRSC(1:KF_SCALARS) -ELSE - DO J=1,KF_UV - IFLDPTRUV(J) = J - ENDDO - DO J=1,KF_SCALARS - IFLDPTRSC(J) = J - ENDDO -ENDIF - -!loop over wavenumber -DO KMLOC=1,D_NUMP - KM = D_MYMS(KMLOC) - -ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) -IDGNH = R%NDGNH -IDGL = R%NDGL -!$acc parallel loop -DO JGL=ISL,IDGNH - IPROC = D%NPROCL(JGL) - ISTAN(JGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*2*KF_OUT_LT - IGLS = IDGL+1-JGL - IPROCS = D%NPROCL(IGLS) - ISTAS(JGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*2*KF_OUT_LT -ENDDO - -!$acc parallel loop collapse(2) -DO JGL=ISL,IDGNH - DO JFLD=1,2*KF_OUT_LT - IGLS = IDGL+1-JGL - ZFIELD(JFLD,JGL) = FOUBUF_IN(ISTAN(JGL)+JFLD) - ZFIELD(JFLD,IGLS) = FOUBUF_IN(ISTAS(JGL)+JFLD) - ENDDO -ENDDO - -IST = 1 -IF(LVORGP) THEN - IST = IST+2*KF_UV -ENDIF -IF(LDIVGP) THEN - IST = IST+2*KF_UV -ENDIF -IPTRU = IST - - - - -CALL FSPGL_PROC(KM,ISL,IDGL,KF_OUT_LT,F%R1MU2,ZFIELD,& - & IPTRU,KF_UV,KF_SCALARS,& - & IFLDPTRUV) - - !$acc parallel loop collapse(2) -DO JGL=ISL,IDGNH - DO JFLD=1,2*KF_OUT_LT - IGLS = IDGL+1-JGL - !OCL NOVREC - FOUBUF_IN(ISTAN(JGL)+JFLD) = ZFIELD(JFLD,JGL) - FOUBUF_IN(ISTAS(JGL)+JFLD) = ZFIELD(JFLD,IGLS) - ENDDO -ENDDO - -!end loop over wavenumber -END DO - -!$acc end data -!$acc end data -! ------------------------------------------------------------------ - -END SUBROUTINE FSPGL_INT -END MODULE FSPGL_INT_MOD diff --git a/src/trans/gpu/internal/ftdir_ctl_mod.F90 b/src/trans/gpu/internal/ftdir_ctl_mod.F90 deleted file mode 100755 index dcfa4bd26..000000000 --- a/src/trans/gpu/internal/ftdir_ctl_mod.F90 +++ /dev/null @@ -1,238 +0,0 @@ -! (C) Copyright 2000- 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 FTDIR_CTL_MOD -CONTAINS -SUBROUTINE FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & - & KVSETUV,KVSETSC,KPTRGP,& - & KVSETSC3A,KVSETSC3B,KVSETSC2,& - & PGP,PGPUV,PGP3A,PGP3B,PGP2) - - -!**** *FTDIR_CTL - Direct Fourier transform control - -! Purpose. Control routine for Grid-point to Fourier transform -! -------- - -!** Interface. -! ---------- -! CALL FTDIR_CTL(..) - -! Explicit arguments : -! -------------------- -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! PGP - gridpoint array -! KVSETUV - "B" set in spectral/fourier space for -! u and v variables -! KVSETSC - "B" set in spectral/fourier space for -! scalar variables -! KPTRGP - pointer array to fields in gridpoint space - -! Method. -! ------- - -! Externals. TRGTOL - transposition routine -! ---------- FOURIER_OUT - copy fourier data to Fourier buffer -! FTDIR - fourier transform - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_GEN, only: nout -!USE TPM_DIM -!USE TPM_GEOMETRY -USE TPM_TRANS ,ONLY : ZGTF, FOUBUF_IN -USE TPM_DISTR ,ONLY : D, MYPROC, NPROC - -USE TRGTOL_MOD ,ONLY : TRGTOL, TRGTOL_CUDAAWARE -USE FOURIER_OUT_MOD ,ONLY : FOURIER_OUT -USE FTDIR_MOD ,ONLY : FTDIR -use ieee_arithmetic -! - -IMPLICIT NONE - - -INTERFACE - SUBROUTINE cudaProfilerStart() BIND(C,name='cudaProfilerStart') - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT - IMPLICIT NONE - END SUBROUTINE cudaProfilerStart -END INTERFACE - -INTERFACE - SUBROUTINE cudaProfilerStop() BIND(C,name='cudaProfilerStop') - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT - IMPLICIT NONE - END SUBROUTINE cudaProfilerStop -END INTERFACE - -! Dummy arguments - -INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP(:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP2(:,:,:) - -! Local variables -!REAL(KIND=JPRBT),ALLOCATABLE :: ZGTF(:,:) - -INTEGER(KIND=JPIM) :: IST,JGL,IGL,JF_FS -INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) -INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) -INTEGER(KIND=JPIM) :: IVSET(KF_GP) -INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC -INTEGER(KIND=JPIM) :: ISIZE,IFIELDS,ICHUNK,ICHUNKS,JK - -! ------------------------------------------------------------------ - -! Field distribution in Spectral/Fourier space - -!call cudaProfilerStart() - -IF(PRESENT(KVSETUV)) THEN - IVSETUV(:) = KVSETUV(:) -ELSE - IVSETUV(:) = -1 -ENDIF -IVSETSC(:) = -1 -IF(PRESENT(KVSETSC)) THEN - IVSETSC(:) = KVSETSC(:) -ELSE - IOFF=0 - IF(PRESENT(KVSETSC2)) THEN - IFGP2=UBOUND(KVSETSC2,1) - IVSETSC(1:IFGP2)=KVSETSC2(:) - IOFF=IOFF+IFGP2 - ENDIF - IF(PRESENT(KVSETSC3A)) THEN - IFGP3A=UBOUND(KVSETSC3A,1) - DO J3=1,UBOUND(PGP3A,3) - IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) - IOFF=IOFF+IFGP3A - ENDDO - ENDIF - IF(PRESENT(KVSETSC3B)) THEN - IFGP3B=UBOUND(KVSETSC3B,1) - DO J3=1,UBOUND(PGP3B,3) - IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) - IOFF=IOFF+IFGP3B - ENDDO - ENDIF -ENDIF - -IST = 1 -IF(KF_UV_G > 0) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G -ENDIF -IF(KF_SCALARS_G > 0) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G -ENDIF - -! Transposition - -CALL GSTATS(158,0) - -! needed ??? JF_FS=KF_FS-D%IADJUST_D -#ifdef USE_CUDA_AWARE_MPI_FT -CALL GSTATS(430,0) -!$ACC DATA IF(PRESENT(PGP)) COPYIN(PGP) -!$ACC DATA IF(PRESENT(PGPUV)) COPYIN(PGPUV) -!$ACC DATA IF(PRESENT(PGP2)) COPYIN(PGP2) -!$ACC DATA IF(PRESENT(PGP3A)) COPYIN(PGP3A) -!$ACC DATA IF(PRESENT(PGP3B)) COPYIN(PGP3B) -CALL GSTATS(430,1) -CALL TRGTOL_CUDAAWARE(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) -!$ACC END DATA -!$ACC END DATA -!$ACC END DATA -!$ACC END DATA -!$ACC END DATA -#else -CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) -!$ACC UPDATE DEVICE(ZGTF) -#endif - -CALL GSTATS(158,1) -CALL GSTATS(106,0) - -! Fourier transform - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -!write(301,*) 'sizey: ', myproc, size(zgtf,1), KF_FS - -CALL GSTATS(1640,0) -!!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) -IF(KF_FS>0) THEN - ! TRY THIS IN CHUNKS, ISIZE is even, need equal and even chunks too - ISIZE=size(zgtf,1) - !ICHUNKS=2 - !ICHUNK=ISIZE/ICHUNKS - !ICHUNK=ICHUNK+MOD(ICHUNK,2) - !DO JK=ICHUNKS,1,-1 - ! repeat some fields to have constant chunk size - !IOFF=MAX(1,ISIZE-(ICHUNKS-JK+1)*ICHUNK+1) - IOFF=1 - !ICHUNK=2*KF_FS+2 - ICHUNK=ISIZE - CALL FTDIR(ICHUNK) - !ENDDO -ENDIF - -! Save Fourier data in FOUBUF_IN - - CALL FOURIER_OUT(KF_FS) -#ifndef USE_CUDA_AWARE_MPI_FT - !$ACC UPDATE HOST(FOUBUF_IN) -#endif - -CALL GSTATS(1640,1) -!DEALLOCATE(ZGTF) -CALL GSTATS(106,1) -! ------------------------------------------------------------------ -!call cudaProfilerStop() -END SUBROUTINE FTDIR_CTL -END MODULE FTDIR_CTL_MOD - diff --git a/src/trans/gpu/internal/ftdir_ctlad_mod.F90 b/src/trans/gpu/internal/ftdir_ctlad_mod.F90 deleted file mode 100755 index 5e227fc2b..000000000 --- a/src/trans/gpu/internal/ftdir_ctlad_mod.F90 +++ /dev/null @@ -1,186 +0,0 @@ -! (C) Copyright 2000- 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 FTDIR_CTLAD_MOD -CONTAINS -SUBROUTINE FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & - & KVSETUV,KVSETSC,KPTRGP,& - & KVSETSC3A,KVSETSC3B,KVSETSC2,& - & PGP,PGPUV,PGP3A,PGP3B,PGP2) - - -!**** *FTDIR_CTLAD - Direct Fourier transform control - adjoint - -! Purpose. Control routine for Grid-point to Fourier transform -! -------- - -!** Interface. -! ---------- -! CALL FTDIR_CTLAD(..) - -! Explicit arguments : -! -------------------- -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! PGP - gridpoint array -! KVSETUV - "B" set in spectral/fourier space for -! u and v variables -! KVSETSC - "B" set in spectral/fourier space for -! scalar variables -! KPTRGP - pointer array to fields in gridpoint space - -! Method. -! ------- - -! Externals. TRGTOL - transposition routine -! ---------- FOURIER_OUT - copy fourier data to Fourier buffer -! FTDIR - fourier transform - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -!USE TPM_GEN -!USE TPM_DIM -!USE TPM_GEOMETRY -USE TPM_DISTR ,ONLY : D, MYPROC, NPROC - -USE TRLTOG_MOD ,ONLY : TRLTOG -USE FOURIER_OUTAD_MOD ,ONLY : FOURIER_OUTAD -USE FTDIRAD_MOD ,ONLY : FTDIRAD -! - -IMPLICIT NONE - -! Dummy arguments - -INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) -REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP(:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP2(:,:,:) - -! Local variables -REAL(KIND=JPRBT) :: ZGTF(KF_FS,D%NLENGTF) - - -INTEGER(KIND=JPIM) :: IST -INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) -INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) -INTEGER(KIND=JPIM) :: IVSET(KF_GP) -INTEGER(KIND=JPIM) :: JGL,IGL -INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC - -! ------------------------------------------------------------------ - -! Field distribution in Spectral/Fourier space - -CALL GSTATS(133,0) - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -CALL GSTATS(1642,0) -!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) -DO JGL=IBEG,IEND,IINC - IGL = JGL - CALL FOURIER_OUTAD(ZGTF,KF_FS,IGL) - -! Fourier transform - - IF(KF_FS>0) THEN - CALL FTDIRAD(ZGTF,KF_FS,IGL) - ENDIF -ENDDO -!$OMP END PARALLEL DO -CALL GSTATS(1642,1) -CALL GSTATS(133,1) - -! Transposition - -CALL GSTATS(183,0) -IF(PRESENT(KVSETUV)) THEN - IVSETUV(:) = KVSETUV(:) -ELSE - IVSETUV(:) = -1 -ENDIF -IVSETSC(:) = -1 -IF(PRESENT(KVSETSC)) THEN - IVSETSC(:) = KVSETSC(:) -ELSE - IOFF=0 - IF(PRESENT(KVSETSC2)) THEN - IFGP2=UBOUND(KVSETSC2,1) - IVSETSC(1:IFGP2)=KVSETSC2(:) - IOFF=IOFF+IFGP2 - ENDIF - IF(PRESENT(KVSETSC3A)) THEN - IFGP3A=UBOUND(KVSETSC3A,1) - DO J3=1,UBOUND(PGP3A,3) - IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) - IOFF=IOFF+IFGP3A - ENDDO - ENDIF - IF(PRESENT(KVSETSC3B)) THEN - IFGP3B=UBOUND(KVSETSC3B,1) - DO J3=1,UBOUND(PGP3B,3) - IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) - IOFF=IOFF+IFGP3B - ENDDO - ENDIF -ENDIF - -IST = 1 -IF(KF_UV_G > 0) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G -ENDIF -IF(KF_SCALARS_G > 0) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G -ENDIF -CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) - -CALL GSTATS(183,1) - -! ------------------------------------------------------------------ - -END SUBROUTINE FTDIR_CTLAD -END MODULE FTDIR_CTLAD_MOD - - - diff --git a/src/trans/gpu/internal/ftdir_mod.F90 b/src/trans/gpu/internal/ftdir_mod.F90 index 87cfeb031..bcce3e749 100755 --- a/src/trans/gpu/internal/ftdir_mod.F90 +++ b/src/trans/gpu/internal/ftdir_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,145 +9,95 @@ ! MODULE FTDIR_MOD + IMPLICIT NONE + + TYPE FTDIR_HANDLE + END TYPE CONTAINS -SUBROUTINE FTDIR(KFIELDS) + FUNCTION PREPARE_FTDIR() RESULT(HFTDIR) + IMPLICIT NONE + TYPE(FTDIR_HANDLE) :: HFTDIR + END FUNCTION -!**** *FTDIR - Direct Fourier transform + SUBROUTINE FTDIR(HFTDIR,PREEL_REAL,PREEL_COMPLEX,KFIELD) + !**** *FTDIR - Direct Fourier transform -! Purpose. Routine for Grid-point to Fourier transform -! -------- + ! Purpose. Routine for Grid-point to Fourier transform + ! -------- -!** Interface. -! ---------- -! CALL FTDIR(..) + !** Interface. + ! ---------- + ! CALL FTDIR(..) -! Explicit arguments : PREEL - Fourier/grid-point array -! -------------------- KFIELDS - number of fields + ! Explicit arguments : PREEL - Fourier/grid-point array + ! -------------------- KFIELD - number of fields -! Method. -! ------- + ! Method. + ! ------- -! Externals. FFT992 - FFT routine -! ---------- -! + ! Externals. FFT992 - FFT routine + ! ---------- + ! -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 -! G. Radnoti 01-04-24 2D model (NLOEN=1) -! D. Degrauwe (Feb 2012): Alternative extension zone (E') -! G. Mozdzynski (Oct 2014): support for FFTW transforms -! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM, JPIB, JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC,D_NSTAGTF,D_NPTRLS -USE TPM_TRANS ,ONLY : ZGTF -USE TPM_GEOMETRY ,ONLY : G,G_NMEN,G_NMEN_MAX,G_NLOEN,G_NLOEN_MAX -USE TPM_FFT ,ONLY : T -#ifdef WITH_FFTW -USE TPM_FFTW ,ONLY : TW, EXEC_FFTW -#endif -USE TPM_FFTC ,ONLY : CREATE_PLAN_FFT -USE TPM_DIM ,ONLY : R,R_NNOEXTZL -USE CUDA_DEVICE_MOD -! + ! Author. + ! ------- + ! Mats Hamrud *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 00-03-03 + ! G. Radnoti 01-04-24 2D model (NLOEN=1) + ! D. Degrauwe (Feb 2012): Alternative extension zone (E') + ! G. Mozdzynski (Oct 2014): support for FFTW transforms + ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW + ! ------------------------------------------------------------------ + + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT + + USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC + USE TPM_GEOMETRY ,ONLY : G + USE TPM_FFTC ,ONLY : EXECUTE_DIR_FFT + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + IMPLICIT NONE + + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + REAL(KIND=JPRBT), INTENT(INOUT), POINTER :: PREEL_REAL(:) + REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) + TYPE(FTDIR_HANDLE) :: HFTDIR + + INTEGER(KIND=JPIM) :: KGL + + ! ------------------------------------------------------------------ + + PREEL_COMPLEX => PREEL_REAL + + !$ACC DATA PRESENT(PREEL_REAL,PREEL_COMPLEX) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) + ENDIF + CALL GSTATS(413,0) + CALL EXECUTE_DIR_FFT(PREEL_REAL(:),PREEL_COMPLEX(:),KFIELD, & + & LOENS=G%NLOEN(D%NPTRLS(MYSETW):D%NPTRLS(MYSETW)+D%NDGL_FS-1), & + & OFFSETS=D%NSTAGTF(1:D%NDGL_FS+1)) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(433,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(433,1) + ENDIF + CALL GSTATS(413,1) + + !$ACC END DATA + + NULLIFY(PREEL_REAL) -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS -INTEGER(KIND=JPIM) :: KGL -!!!REAL(KIND=JPRBT), INTENT(INOUT) :: PREEL(KFIELDS,D%NLENGTF) - -INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,IST1 -INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE -INTEGER(KIND=JPIM) :: IPLAN_R2C -INTEGER(KIND=JPIM) :: JMAX -REAL(KIND=JPRBT) :: SCAL -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time - -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC,ISCAL -INTEGER(KIND=JPIM) :: OFFSET_VAR, IUNIT, ISIZE, II, IMAX -integer :: istat, idev -real(kind=jprbt), allocatable :: zgtf2(:,:) - -! ------------------------------------------------------------------ - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -OFFSET_VAR=D_NPTRLS(MYSETW) - -IMAX = G_NLOEN_MAX + 2 + R_NNOEXTZL - - -allocate(zgtf2(size(zgtf,1),size(zgtf,2))) -!$ACC DATA & -!$ACC& PRESENT(ZGTF,D,D_NSTAGTF,D_NPTRLS,G_NMEN,G_NMEN_MAX,G_NLOEN,G_NLOEN_MAX,R_NNOEXTZL) - -!$ACC DATA CREATE(ZGTF2) - -!!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(KGL,IOFF,IGLG,IPLAN_R2C,istat) -DO KGL=IBEG,IEND,IINC - - IOFF=D%NSTAGTF(KGL)+1 - IGLG = D%NPTRLS(MYSETW)+KGL-1 - !ILEN = G_NLOEN(IGLG)+R_NNOEXTZL+3-IST - !IRLEN=G_NLOEN(IGLG)+R_NNOEXTZL - !ICLEN=(IRLEN/2+1)*2 - - CALL CREATE_PLAN_FFT(IPLAN_R2C,-1,G%NLOEN(IGLG),KFIELDS) - !$ACC host_data use_device(ZGTF,ZGTF2) - CALL EXECUTE_PLAN_FFTC(IPLAN_R2C,-1,ZGTF(1,IOFF),ZGTF2(1,IOFF)) - !$ACC end host_data -END DO -!!$OMP END PARALLEL DO - -istat = cuda_Synchronize() - -!$acc kernels DEFAULT(NONE) -zgtf(:,:) = zgtf2(:,:) -!$acc end kernels -!$acc end data - -!$ACC parallel loop collapse(3) private(JMAX,KGL,IOFF,SCAL,IST) DEFAULT(NONE) -DO IGLG=IBEG+OFFSET_VAR-1,IEND+OFFSET_VAR-1,IINC - DO JJ=1, IMAX - DO JF=1,KFIELDS - JMAX = G_NLOEN(IGLG) - IST = 2*(G_NMEN(IGLG)+1) - if (JJ .le. JMAX) then - KGL=IGLG-OFFSET_VAR+1 - IOFF=D_NSTAGTF(KGL)+1 - SCAL = 1._JPRBT/REAL(G_NLOEN(IGLG),JPRBT) - ZGTF(JF,IOFF+JJ-1)= SCAL * ZGTF(JF, IOFF+JJ-1) - end if - - ! case JJ>0 - IF( JJ .le. (JMAX+R_NNOEXTZL+2-IST)) ZGTF(JF,IST+IOFF+JJ-1) = 0.0_JPRBT - ! case JJ=0 - IF (G_NLOEN(IGLG)==1) ZGTF(JF,IST+IOFF-1) = 0.0_JPRBT - ENDDO - ENDDO -ENDDO - -!$ACC end data - -! ------------------------------------------------------------------ - -END SUBROUTINE FTDIR + ! ------------------------------------------------------------------ + END SUBROUTINE FTDIR END MODULE FTDIR_MOD diff --git a/src/trans/gpu/internal/ftdirad_mod.F90 b/src/trans/gpu/internal/ftdirad_mod.F90 deleted file mode 100755 index d074fd4cb..000000000 --- a/src/trans/gpu/internal/ftdirad_mod.F90 +++ /dev/null @@ -1,119 +0,0 @@ -! (C) Copyright 2000- 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 FTDIRAD_MOD -CONTAINS -SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) - - -!**** *FTDIRAD - Direct Fourier transform - -! Purpose. Routine for Grid-point to Fourier transform - adjoint -! -------- - -!** Interface. -! ---------- -! CALL FTDIRAD(..) - -! Explicit arguments : PREEL - Fourier/grid-point array -! -------------------- KFIELDS - number of fields - -! Method. -! ------- - -! Externals. FFT992 - FFT routine -! ---------- -! - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 -! D. Degrauwe (Feb 2012): Alternative extension zone (E') -! G. Mozdzynski (Oct 2014): support for FFTW transforms -! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW -USE TPM_GEOMETRY ,ONLY : G -USE TPM_FFT ,ONLY : T -#ifdef WITH_FFTW -USE TPM_FFTW ,ONLY : TW, EXEC_FFTW -#endif -USE TPM_DIM ,ONLY : R - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL -REAL(KIND=JPRBT), INTENT(INOUT) :: PREEL(:,:) - -INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN -INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE -REAL(KIND=JPRBT) :: ZMUL -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time -! ------------------------------------------------------------------ - -ITYPE = 1 -IJUMP = 1 -IGLG = D%NPTRLS(MYSETW)+KGL-1 -IST = 2*(G%NMEN(IGLG)+1)+1 -ILOEN = G%NLOEN(IGLG)+R%NNOEXTZL -ILEN = ILOEN+3-IST -IOFF = D%NSTAGTF(KGL)+1 -IRLEN = ILOEN -ICLEN = (IRLEN/2+1)*2 - -DO JJ=1,ILEN - DO JF=1,KFIELDS - PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRBT - ENDDO -ENDDO - -#ifdef WITH_FFTW -IF( .NOT. TW%LFFTW )THEN -#endif - -!! IF( T%LUSEFFT992(KGL) )THEN -!! -!! CALL FFT992(PREEL(1,IOFF),T%TRIGS(1,KGL),& -!! &T%NFAX(1,KGL),KFIELDS,IJUMP,ILOEN,KFIELDS,ITYPE) -!! -!! ELSE -!! -!! CALL BLUESTEIN_FFT(TB,ILOEN,ITYPE,KFIELDS,PREEL(1:KFIELDS,IOFF:IOFF+ICLEN-1)) -!! -!! ENDIF - -#ifdef WITH_FFTW -ELSE - -! CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,LL_ALL,PREEL) - -ENDIF -#endif - - ! Change of metric (not in forward routine) - -ZMUL = 1.0_JPRBT/ILOEN -DO JJ=1,ILOEN - DO JF=1,KFIELDS - PREEL(JF,IOFF-1+JJ) = PREEL(JF,IOFF-1+JJ)*ZMUL - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE FTDIRAD -END MODULE FTDIRAD_MOD diff --git a/src/trans/gpu/internal/ftinv_ctl_mod.F90 b/src/trans/gpu/internal/ftinv_ctl_mod.F90 deleted file mode 100755 index d8c087f0d..000000000 --- a/src/trans/gpu/internal/ftinv_ctl_mod.F90 +++ /dev/null @@ -1,278 +0,0 @@ -! (C) Copyright 2000- 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 FTINV_CTL_MOD -CONTAINS -SUBROUTINE FTINV_CTL(KF_UV_G,KF_SCALARS_G,& - & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & - & KVSETSC3A,KVSETSC3B,KVSETSC2,& - & PGP,PGPUV,PGP3A,PGP3B,PGP2) - - -!**** *FTINV_CTL - Inverse Fourier transform control - -! Purpose. Control routine for Fourier to Gridpoint transform -! -------- - -!** Interface. -! ---------- -! CALL FTINV_CTL(..) - -! Explicit arguments : -! -------------------- -! PGP - gridpoint array -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! KF_SCDERS - local number of derivatives of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! KF_OUT_LT - total number of fields coming out from inverse LT -! KVSETUV - "B" set in spectral/fourier space for -! u and v variables -! KVSETSC - "B" set in spectral/fourier space for -! scalar variables -! KPTRGP - pointer array to fi3elds in gridpoint space - -! Method. -! ------- - -! Externals. TRLTOG - transposition routine -! ---------- FOURIER_IN - copy fourier data from Fourier buffer -! FTINV - fourier transform -! FSC - Fourier space computations - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_GEN ,ONLY : NERR, nout -!USE TPM_DIM -!USE TPM_GEOMETRY -USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP,LATLON, ZGTF -USE TPM_DISTR ,ONLY : D, MYPROC, NPROC -USE TPM_FLT ,ONLY : S -USE FOURIER_IN_MOD ,ONLY : FOURIER_IN -USE FSC_MOD ,ONLY : FSC -USE FTINV_MOD ,ONLY : FTINV -USE TRLTOG_MOD ,ONLY : TRLTOG, TRLTOG_CUDAAWARE -USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS -use ieee_arithmetic -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) - -INTEGER(KIND=JPIM) :: IST -INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) -INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) -INTEGER(KIND=JPIM) :: IVSET(KF_GP) -INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC - -REAL(KIND=JPRBT),POINTER :: ZUV(:,:) -REAL(KIND=JPRBT),POINTER :: ZSCALAR(:,:) -REAL(KIND=JPRBT),POINTER :: ZNSDERS(:,:) -REAL(KIND=JPRBT),POINTER :: ZEWDERS(:,:) -REAL(KIND=JPRBT),POINTER :: ZUVDERS(:,:) -#if 0 -REAL(KIND=JPRBT),TARGET :: ZDUM(1,D%NLENGTF) ! Reducing stack usage here, too -#else -REAL(KIND=JPRBT),TARGET,ALLOCATABLE :: ZDUM(:,:) ! When using this (HEAP) alloc Cray CCE 8.6.2 fails in OMP 1639 -#endif -INTEGER(KIND=JPIM) :: ist_uv, ist_sc, ist_nsders, ist_uvders, ist_ewders, JF_FS - -ist_uv = 1 -ist_sc = 1 -ist_nsders = 1 -ist_uvders = 1 -ist_ewders = 1 - -! ------------------------------------------------------------------ - -! 1. Copy Fourier data to local array - -CALL GSTATS(107,0) - -IF (KF_UV > 0 .OR. KF_SCDERS > 0 .OR. (LATLON.AND.S%LDLL) ) THEN - IST = 1 - IF (LVORGP) THEN - IST = IST+KF_UV - ENDIF - IF (LDIVGP) THEN - IST = IST+KF_UV - ENDIF - IST_UV = IST - IST = IST+2*KF_UV - IST_SC = IST - IST = IST+KF_SCALARS - IST_NSDERS = IST - IST = IST+KF_SCDERS - IF (LUVDER) THEN - IST_UVDERS = IST - IST = IST+2*KF_UV - ENDIF - IF (KF_SCDERS > 0) THEN - IST_EWDERS = IST - ENDIF -ENDIF -IF (MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -CALL GSTATS(1639,0) -! from FOUBUF to ZGTF -CALL FOURIER_IN(ZGTF,KF_OUT_LT) - -! 2. Fourier space computations - -IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN - CALL FSC(KF_UV,KF_SCALARS,KF_SCDERS,IST_UV,IST_SC,IST_NSDERS,IST_EWDERS,IST_UVDERS) -ENDIF - -! 3. Fourier transform -IF(KF_FS > 0) THEN - ! from ZGTF to ZGTF - CALL FTINV(ZGTF,size(zgtf,1)) -ENDIF - -CALL GSTATS(1639,1) - -CALL GSTATS(107,1) - -! 4. Transposition - -IF (PRESENT(KVSETUV)) THEN - IVSETUV(:) = KVSETUV(:) -ELSE - IVSETUV(:) = -1 -ENDIF -IVSETSC(:)=-1 -IF (PRESENT(KVSETSC)) THEN - IVSETSC(:) = KVSETSC(:) -ELSE - IOFF=0 - IF (PRESENT(KVSETSC2)) THEN - IFGP2=UBOUND(KVSETSC2,1) - IVSETSC(1:IFGP2)=KVSETSC2(:) - IOFF=IOFF+IFGP2 - ENDIF - IF (PRESENT(KVSETSC3A)) THEN - IFGP3A=UBOUND(KVSETSC3A,1) - IGP3APAR=UBOUND(PGP3A,3) - IF (LSCDERS) IGP3APAR=IGP3APAR/3 - DO J3=1,IGP3APAR - IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) - IOFF=IOFF+IFGP3A - ENDDO - ENDIF - IF (PRESENT(KVSETSC3B)) THEN - IFGP3B=UBOUND(KVSETSC3B,1) - IGP3BPAR=UBOUND(PGP3B,3) - IF (LSCDERS) IGP3BPAR=IGP3BPAR/3 - DO J3=1,IGP3BPAR - IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) - IOFF=IOFF+IFGP3B - ENDDO - ENDIF - IF (IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN - WRITE(NERR,*)'FTINV:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G - CALL ABORT_TRANS('FTINV_CTL_MOD:IOFF /= KF_SCALARS_G') - ENDIF -ENDIF - -IST = 1 -IF (KF_UV_G > 0) THEN - IF (LVORGP) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - ENDIF - IF ( LDIVGP) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - ENDIF - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G -ENDIF -IF (KF_SCALARS_G > 0) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G - IF (LSCDERS) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G - ENDIF -ENDIF -IF (KF_UV_G > 0 .AND. LUVDER) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G -ENDIF -IF (KF_SCALARS_G > 0) THEN - IF (LSCDERS) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G - ENDIF -ENDIF - -CALL GSTATS(157,0) -JF_FS=KF_FS-D%IADJUST_I -#ifdef USE_CUDA_AWARE_MPI_FT -WRITE(NOUT,*) 'ftinv_ctl:TRLTOG_CUDAAWARE' -CALL TRLTOG_CUDAAWARE(ZGTF,JF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) -#else -!WRITE(NOUT,*) 'ftinv_ctl:TRLTOG' -!$ACC UPDATE HOST(ZGTF) -CALL TRLTOG(ZGTF,JF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) -#endif -CALL GSTATS(157,1) -! ------------------------------------------------------------------ - -!DEALLOCATE(ZGTF) - -END SUBROUTINE FTINV_CTL -END MODULE FTINV_CTL_MOD diff --git a/src/trans/gpu/internal/ftinv_ctlad_mod.F90 b/src/trans/gpu/internal/ftinv_ctlad_mod.F90 deleted file mode 100755 index 55b8cb377..000000000 --- a/src/trans/gpu/internal/ftinv_ctlad_mod.F90 +++ /dev/null @@ -1,292 +0,0 @@ -! (C) Copyright 2000- 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 FTINV_CTLAD_MOD -CONTAINS -SUBROUTINE FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& - & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & - & KVSETSC3A,KVSETSC3B,KVSETSC2,& - & PGP,PGPUV,PGP3A,PGP3B,PGP2) - - -!**** *FTINV_CTLAD - Inverse Fourier transform control - adjoint - -! Purpose. Control routine for Fourier to Gridpoint transform -! -------- - -!** Interface. -! ---------- -! CALL FTINV_CTLAD(..) - -! Explicit arguments : -! -------------------- -! PGP - gridpoint array -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! KF_SCDERS - local number of derivatives of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! KF_OUT_LT - total number of fields coming out from inverse LT -! KVSETUV - "B" set in spectral/fourier space for -! u and v variables -! KVSETSC - "B" set in spectral/fourier space for -! scalar variables -! KPTRGP - pointer array to fi3elds in gridpoint space - - -! Method. -! ------- - -! Externals. TRLTOG - transposition routine -! ---------- FOURIER_IN - copy fourier data from Fourier buffer -! FTINV - fourier transform -! FSC - Fourier space computations - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_GEN ,ONLY : NERR -!USE TPM_DIM -!USE TPM_GEOMETRY -USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP -USE TPM_DISTR ,ONLY : D, MYPROC, NPROC - -USE FOURIER_INAD_MOD ,ONLY : FOURIER_INAD -USE FSCAD_MOD ,ONLY : FSCAD -USE FTINVAD_MOD ,ONLY : FTINVAD -USE TRGTOL_MOD ,ONLY : TRGTOL -USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP(:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL , INTENT(IN) :: PGP2(:,:,:) - -! ------------------------------------------------------------------ - -REAL(KIND=JPRBT),TARGET :: ZGTF(KF_FS,D%NLENGTF) -REAL(KIND=JPRBT),TARGET :: ZDUM(1,D%NLENGTF) -REAL(KIND=JPRBT),POINTER :: ZUV(:,:) -REAL(KIND=JPRBT),POINTER :: ZSCALAR(:,:) -REAL(KIND=JPRBT),POINTER :: ZNSDERS(:,:) -REAL(KIND=JPRBT),POINTER :: ZEWDERS(:,:) -REAL(KIND=JPRBT),POINTER :: ZUVDERS(:,:) - -INTEGER(KIND=JPIM) :: IST,IBLEN -INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) -INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) -INTEGER(KIND=JPIM) :: IVSET(KF_GP) -INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC - -! ------------------------------------------------------------------ - -! 4. Transposition - -IF(PRESENT(KVSETUV)) THEN - IVSETUV(:) = KVSETUV(:) -ELSE - IVSETUV(:) = -1 -ENDIF - -IVSETSC(:)=-1 -IF(PRESENT(KVSETSC)) THEN - IVSETSC(:) = KVSETSC(:) -ELSE - IOFF=0 - IF(PRESENT(KVSETSC2)) THEN - IFGP2=UBOUND(KVSETSC2,1) - IVSETSC(1:IFGP2)=KVSETSC2(:) - IOFF=IOFF+IFGP2 - ENDIF - IF(PRESENT(KVSETSC3A)) THEN - IFGP3A=UBOUND(KVSETSC3A,1) - IGP3APAR=UBOUND(PGP3A,3) - IF(LSCDERS) IGP3APAR=IGP3APAR/3 - DO J3=1,IGP3APAR - IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) - IOFF=IOFF+IFGP3A - ENDDO - ENDIF - IF(PRESENT(KVSETSC3B)) THEN - IFGP3B=UBOUND(KVSETSC3B,1) - IGP3BPAR=UBOUND(PGP3B,3) - IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 - DO J3=1,IGP3BPAR - IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) - IOFF=IOFF+IFGP3B - ENDDO - ENDIF - IF(IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN - WRITE(NERR,*)'FTINV_CTLAD:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G - CALL ABORT_TRANS('FTINV_CTLAD_MOD:IOFF /= KF_SCALARS_G') - ENDIF -ENDIF - -IST = 1 -IF(KF_UV_G > 0) THEN - IF( LVORGP) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - ENDIF - IF( LDIVGP) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - ENDIF - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G -ENDIF -IF(KF_SCALARS_G > 0) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G - IF(LSCDERS) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G - ENDIF -ENDIF -IF(KF_UV_G > 0 .AND. LUVDER) THEN - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G - IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) - IST = IST+KF_UV_G -ENDIF -IF(KF_SCALARS_G > 0) THEN - IF(LSCDERS) THEN - IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) - IST = IST+KF_SCALARS_G - ENDIF -ENDIF - -CALL GSTATS(182,0) -CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) -CALL GSTATS(182,1) - -! 3. Fourier transform - -IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN - IST = 1 - IF(LVORGP) THEN - IST = IST+KF_UV - ENDIF - IF(LDIVGP) THEN - IST = IST+KF_UV - ENDIF - IF(KF_UV>0)ZUV => ZGTF(IST:IST+2*KF_UV-1,:) - IST = IST+2*KF_UV - IF(KF_SCALARS>0)ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) - IST = IST+KF_SCALARS - IF(KF_SCDERS>0)ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) - IST = IST+KF_SCDERS - IF(LUVDER) THEN - ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) - IST = IST+2*KF_UV - ELSE - ZUVDERS => ZDUM(1:1,:) - ENDIF - IF(KF_SCDERS > 0) THEN - ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) - ELSE - ZEWDERS => ZDUM(1:1,:) - ENDIF -ENDIF - -IBLEN = D%NLENGT0B*2*KF_OUT_LT -IF (ALLOCATED(FOUBUF)) THEN - IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN - DEALLOCATE(FOUBUF) - ALLOCATE(FOUBUF(MAX(1,IBLEN))) - ENDIF -ELSE - ALLOCATE(FOUBUF(MAX(1,IBLEN))) -ENDIF - -CALL GSTATS(132,0) - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -CALL GSTATS(1641,0) -!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) -DO JGL=IBEG,IEND,IINC - IGL = JGL - IF(KF_FS > 0) THEN - CALL FTINVAD(ZGTF,KF_FS,IGL) - ENDIF - -! 2. Fourier space computations - - IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN - CALL FSCAD(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& - & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) - ENDIF - -! 1. Copy Fourier data to local array - - CALL FOURIER_INAD(ZGTF,KF_OUT_LT,IGL) - -ENDDO -!$OMP END PARALLEL DO -CALL GSTATS(1641,1) - -IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN - NULLIFY(ZUV) - NULLIFY(ZSCALAR) - NULLIFY(ZNSDERS) - NULLIFY(ZUVDERS) - NULLIFY(ZEWDERS) -ENDIF - -CALL GSTATS(132,1) - -! ------------------------------------------------------------------ - -END SUBROUTINE FTINV_CTLAD -END MODULE FTINV_CTLAD_MOD - - - diff --git a/src/trans/gpu/internal/ftinv_mod.F90 b/src/trans/gpu/internal/ftinv_mod.F90 index 26ccbcdd1..757bc6957 100755 --- a/src/trans/gpu/internal/ftinv_mod.F90 +++ b/src/trans/gpu/internal/ftinv_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,136 +9,104 @@ ! MODULE FTINV_MOD + USE ALLOCATOR_MOD + IMPLICIT NONE + + PRIVATE + PUBLIC :: FTINV, FTINV_HANDLE, PREPARE_FTINV + + TYPE FTINV_HANDLE + END TYPE CONTAINS -SUBROUTINE FTINV(PREEL,KFIELDS) + FUNCTION PREPARE_FTINV(ALLOCATOR) RESULT(HFTINV) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D -!**** *FTINV - Inverse Fourier transform + IMPLICIT NONE -! Purpose. Routine for Fourier to Grid-point transform -! -------- + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + TYPE(FTINV_HANDLE) :: HFTINV + END FUNCTION -!** Interface. -! ---------- -! CALL FTINV(..) + SUBROUTINE FTINV(ALLOCATOR,HFTINV,PREEL_COMPLEX,PREEL_REAL,KFIELD) + !**** *FTINV - Inverse Fourier transform -! Explicit arguments : PREEL - Fourier/grid-point array -! -------------------- KFIELDS - number of fields + ! Purpose. Routine for Fourier to Grid-point transform + ! -------- -! Method. -! ------- + !** Interface. + ! ---------- + ! CALL FTINV(..) -! Externals. FFT992 - FFT routine -! ---------- -! + ! Explicit arguments : PREEL - Fourier/grid-point array + ! -------------------- KFIELD - number of fields + + ! Method. + ! ------- + + ! Externals. FFT992 - FFT routine + ! ---------- + ! + + ! Author. + ! ------- + ! Mats Hamrud *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 00-03-03 + ! G. Radnoti 01-04-24 2D model (NLOEN=1) + ! D. Degrauwe (Feb 2012): Alternative extension zone (E') + ! G. Mozdzynski (Oct 2014): support for FFTW transforms + ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW + ! ------------------------------------------------------------------ + + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT + + USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC + USE TPM_GEOMETRY ,ONLY : G + USE TPM_FFTC ,ONLY : EXECUTE_INV_FFT + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + IMPLICIT NONE + + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + REAL(KIND=JPRBT), INTENT(INOUT), POINTER :: PREEL_REAL(:) + REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(FTINV_HANDLE), INTENT(IN) :: HFTINV + + INTEGER(KIND=JPIM) :: KGL,IRET + + ! ------------------------------------------------------------------ + + PREEL_REAL => PREEL_COMPLEX + + !$ACC DATA PRESENT(PREEL_REAL,PREEL_COMPLEX) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) + ENDIF + CALL GSTATS(423,0) + CALL EXECUTE_INV_FFT(PREEL_COMPLEX(:),PREEL_REAL(:),KFIELD, & + & LOENS=G%NLOEN(D%NPTRLS(MYSETW):D%NPTRLS(MYSETW)+D%NDGL_FS-1), & + & OFFSETS=D%NSTAGTF(1:D%NDGL_FS)) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(443,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(443,1) + ENDIF + CALL GSTATS(423,1) + + !$ACC END DATA + + NULLIFY(PREEL_COMPLEX) -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 -! G. Radnoti 01-04-24 : 2D model (NLOEN=1) -! D. Degrauwe (Feb 2012): Alternative extension zone (E') -! G. Mozdzynski (Oct 2014): support for FFTW transforms -! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW, MYPROC, NPROC -USE TPM_GEOMETRY ,ONLY : G -use tpm_gen, only: nout -USE TPM_FFT ,ONLY : T -#ifdef WITH_FFTW -USE TPM_FFTW ,ONLY : TW, EXEC_FFTW -#endif -USE TPM_FFTC ,ONLY : CREATE_PLAN_FFT, destroy_plan_fft -USE TPM_DIM ,ONLY : R -USE CUDA_DEVICE_MOD - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS -INTEGER(KIND=JPIM) :: KGL -REAL(KIND=JPRBT), INTENT(INOUT) :: PREEL(:,:) - -INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,IST1 -INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time -INTEGER(KIND=JPIM) :: IPLAN_C2R -INTEGER(KIND=JPIM) :: IBEG,IEND,IINC,ISIZE -integer :: istat,idev - -REAL(KIND=JPRBT), allocatable :: PREEL2(:,:) - -! ------------------------------------------------------------------ - - - -IF(MYPROC > NPROC/2)THEN - IBEG=1 - IEND=D%NDGL_FS - IINC=1 -ELSE - IBEG=D%NDGL_FS - IEND=1 - IINC=-1 -ENDIF - -ISIZE=size(PREEL,1) - -!$ACC DATA & -!$ACC& PRESENT(PREEL) - -!$ACC PARALLEL LOOP DEFAULT(NONE) -DO KGL=IBEG,IEND,IINC - - IOFF = D%NSTAGTF(KGL)+1 - IGLG = D%NPTRLS(MYSETW)+KGL-1 - IST = 2*(G%NMEN(IGLG)+1) - ILEN = G%NLOEN(IGLG)+R%NNOEXTZL+2-IST - IST1=1 - IF (G%NLOEN(IGLG)==1) IST1=0 - - !$ACC loop collapse(2) - DO JJ=IST1,ILEN - DO JF=1,KFIELDS - PREEL(JF,IST+IOFF+JJ-1) = 0.0_JPRBT - ENDDO - ENDDO - -END DO -!$ACC end data - -allocate(preel2(size(preel,1),size(preel,2))) -!$acc data create(preel2) present(preel) - -!istat = cuda_GetDevice(idev) -!istat = cuda_Synchronize() -!!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(istat,KGL,IOFF,IGLG,IPLAN_C2R) -DO KGL=IBEG,IEND,IINC - IOFF=D%NSTAGTF(KGL)+1 - IGLG = D%NPTRLS(MYSETW)+KGL-1 - !IF (G%NLOEN(IGLG)>1) THEN -!call cudaProfilerStop() - !istat=cuda_SetDevice(idev) - CALL CREATE_PLAN_FFT(IPLAN_C2R,1,G%NLOEN(IGLG),KFIELDS) - !$ACC host_data use_device(PREEL,PREEL2) - CALL EXECUTE_PLAN_FFTC(IPLAN_C2R,1,PREEL(1, ioff),PREEL2(1, ioff)) - !$ACC end host_data -!call cudaProfilerStart() - !ENDIF -END DO -!!$OMP END PARALLEL DO -istat = cuda_Synchronize() - - -!$acc kernels -preel(:,:) = preel2(:,:) -!$acc end kernels -!$acc end data -! ------------------------------------------------------------------ - -END SUBROUTINE FTINV + ! ------------------------------------------------------------------ + END SUBROUTINE FTINV END MODULE FTINV_MOD diff --git a/src/trans/gpu/internal/ftinvad_mod.F90 b/src/trans/gpu/internal/ftinvad_mod.F90 deleted file mode 100755 index 7aa455735..000000000 --- a/src/trans/gpu/internal/ftinvad_mod.F90 +++ /dev/null @@ -1,124 +0,0 @@ -! (C) Copyright 2000- 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 FTINVAD_MOD -CONTAINS -SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) - - -!**** *FTINVAD - Inverse Fourier transform - adjoint - -! Purpose. Routine for Fourier to Grid-point transform -! -------- - -!** Interface. -! ---------- -! CALL FTINVAD(..) - -! Explicit arguments : PREEL - Fourier/grid-point array -! -------------------- KFIELDS - number of fields - -! Method. -! ------- - -! Externals. FFT992 - FFT routine -! ---------- -! - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-03-03 -! D. Degrauwe (Feb 2012): Alternative extension zone (E') -! G. Mozdzynski (Oct 2014): support for FFTW transforms -! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW - -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM, JPIB, JPRBT - -USE TPM_DISTR ,ONLY : D, MYSETW -USE TPM_DIM ,ONLY : R -USE TPM_GEOMETRY ,ONLY : G -USE TPM_FFT ,ONLY : T -#ifdef WITH_FFTW -USE TPM_FFTW ,ONLY : TW, EXEC_FFTW -#endif -USE TPM_DIM ,ONLY : R -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL -REAL(KIND=JPRBT), INTENT(OUT) :: PREEL(:,:) - -INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN -INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE -LOGICAL :: LL_ALL=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time - -! ------------------------------------------------------------------ - -ITYPE =-1 -IJUMP = 1 -IGLG = D%NPTRLS(MYSETW)+KGL-1 -ILOEN = G%NLOEN(IGLG)+R%NNOEXTZL -IST = 2*(G%NMEN(IGLG)+1)+1 -ILEN = ILOEN+3-IST -IOFF = D%NSTAGTF(KGL)+1 -IRLEN = ILOEN -ICLEN = (IRLEN/2+1)*2 - - ! Change of metric (not in forward routine) -DO JJ=1,ILOEN - DO JF=1,KFIELDS - PREEL(JF,IOFF-1+JJ) = PREEL(JF,IOFF-1+JJ)*ILOEN - ENDDO -ENDDO - -#ifdef WITH_FFTW -IF( .NOT. TW%LFFTW )THEN -#endif - -!! IF( T%LUSEFFT992(KGL) )THEN -!! -!! CALL FFT992(PREEL(1,IOFF),T%TRIGS(1,KGL),& -!! &T%NFAX(1,KGL),KFIELDS,IJUMP,ILOEN,KFIELDS,ITYPE) -!! -!! ELSE -!! -!! CALL BLUESTEIN_FFT(TB,ILOEN,ITYPE,KFIELDS,PREEL(1:KFIELDS,IOFF:IOFF+ICLEN-1)) -!! DO JJ=1,ICLEN -!! DO JF=1,KFIELDS -!! PREEL(JF,IOFF-1+JJ)=PREEL(JF,IOFF-1+JJ)/REAL(ILOEN,JPRBT) -!! ENDDO -!! ENDDO -!! -!! ENDIF - -#ifdef WITH_FFTW -ELSE - -! CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,LL_ALL,PREEL) - -ENDIF -#endif - -DO JJ=1,ILEN - DO JF=1,KFIELDS - PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRBT - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE FTINVAD -END MODULE FTINVAD_MOD diff --git a/src/trans/gpu/internal/gstats_label_ifs.F90 b/src/trans/gpu/internal/gstats_label_ifs.F90 index 247d7fc37..72bdf4940 100644 --- a/src/trans/gpu/internal/gstats_label_ifs.F90 +++ b/src/trans/gpu/internal/gstats_label_ifs.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -51,6 +52,7 @@ SUBROUTINE GSTATS_LABEL_IFS USE PARKIND1 ,ONLY : JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE YOMGSTATS +USE TPM_STATS, ONLY: GSTATS_LABEL => GSTATS_LABEL_NVTX IMPLICIT NONE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -217,18 +219,27 @@ SUBROUTINE GSTATS_LABEL_IFS CALL GSTATS_LABEL(400,' ','GSTATS ') CALL GSTATS_LABEL(401,' ','GSTATS HOOK') -CALL GSTATS_LABEL(410,' ','MPI - TRMTOL') -CALL GSTATS_LABEL(411,' ','MPI - TRLTOM') -CALL GSTATS_LABEL(412,' ','MPI - TRLTOG') -CALL GSTATS_LABEL(413,' ','MPI - TRGTOL') -CALL GSTATS_LABEL(420,' ','TRLTOM Barrier') -CALL GSTATS_LABEL(421,' ','TRMTOL Barrier') -CALL GSTATS_LABEL(422,' ','TRLTOG Barrier') -CALL GSTATS_LABEL(423,' ','TRGTOL Barrier') -CALL GSTATS_LABEL(430,' ','DIR COPIES') -CALL GSTATS_LABEL(431,' ','INV COPIES') -CALL GSTATS_LABEL(440,' ','FULL DIRTRANS') -CALL GSTATS_LABEL(441,' ','FULL INVTRANS') +CALL GSTATS_LABEL(410,' ','DIR COMPLETE') +CALL GSTATS_LABEL(411,' ','DIR MPI') +CALL GSTATS_LABEL(412,' ','DIR COPIES') +CALL GSTATS_LABEL(413,' ','DIR FFT') +CALL GSTATS_LABEL(414,' ','DIR GEMMS') +CALL GSTATS_LABEL(430,' ','DIR COMPLETE - LB') +CALL GSTATS_LABEL(431,' ','DIR MPI - LB') +CALL GSTATS_LABEL(432,' ','DIR COPIES - LB') +CALL GSTATS_LABEL(433,' ','DIR FFT - LB') +CALL GSTATS_LABEL(434,' ','DIR GEMMS - LB') + +CALL GSTATS_LABEL(420,' ','INV COMPLETE') +CALL GSTATS_LABEL(421,' ','INV MPI') +CALL GSTATS_LABEL(422,' ','INV COPIES') +CALL GSTATS_LABEL(423,' ','INV FFT') +CALL GSTATS_LABEL(424,' ','INV GEMMS') +CALL GSTATS_LABEL(440,' ','INV COMPLETE - LB') +CALL GSTATS_LABEL(441,' ','INV MPI - LB') +CALL GSTATS_LABEL(442,' ','INV COPIES - LB') +CALL GSTATS_LABEL(443,' ','INV FFT - LB') +CALL GSTATS_LABEL(444,' ','INV GEMMS - LB') ! counters 500 to 2000 CALL GSTATS_LABEL(501,'MPL','SLCOMM2_COMMS PART1') diff --git a/src/trans/gpu/internal/inigptr_mod.F90 b/src/trans/gpu/internal/inigptr_mod.F90 index 87c2a5fd6..9dc55eca0 100755 --- a/src/trans/gpu/internal/inigptr_mod.F90 +++ b/src/trans/gpu/internal/inigptr_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -32,23 +33,23 @@ SUBROUTINE INIGPTR(KGPTRSEND,KGPTRRECV) ! Compute tables to assist GP to/from Fourier space transpositions -KGPTRSEND(:,:,:)=0 +KGPTRSEND(1,:,:)=0 +KGPTRSEND(2,:,:)=-1 IBLOCK=1 IROF=1 IBFIRST=1 IPROCLAST=D%NPROCL(D%NFRSTLOFF+1) +! for each latitude on this processor DO JGL=1,D%NDGL_GP - ! Find processor which deals with this latitude in Fourier distribution + ! find the processor where this row should be saved in the fourier distribution + ! this is called the "w-set" IPROC=D%NPROCL(D%NFRSTLOFF+JGL) - IF(IPROC > NPRTRNS) THEN - WRITE(NOUT,'(A,I8)')& - &' INIGPTR ERROR : exceeding processor limit ',NPRTRNS - CALL ABORT_TRANS(' INIGPTR ERROR : exceeding processor limit ') - ENDIF - ! for each latitude on this processor, find first and last points - ! for each NPROMA chunk, for each destination processor + ! for each latitude on this processor, find first and last points + ! for each NPROMA chunk, for each destination processor IF(IPROC /= IPROCLAST) THEN + ! we got onto a new process, we still need to finish the last block of the previous + ! process IF(IROF > 1) THEN KGPTRSEND(1,IBLOCK,IPROCLAST)=IBFIRST KGPTRSEND(2,IBLOCK,IPROCLAST)=IROF-1 @@ -56,10 +57,14 @@ SUBROUTINE INIGPTR(KGPTRSEND,KGPTRRECV) IF(IROF <= NPROMA) IBFIRST=IROF IPROCLAST=IPROC ENDIF + ! my offset of the first gridpoint in this row (globally, in EW-direction) IFIRST=D%NSTA(D%NPTRFLOFF+JGL,MY_REGION_EW) + ! my offset of the last gridpoint in this row (globally, in EW-direction) ILAST =IFIRST + D%NONL(D%NPTRFLOFF+JGL,MY_REGION_EW) -1 + ! now go through all gridpoints on this latitude DO JBL=IFIRST,ILAST IF(IROF == NPROMA) THEN + ! this block is full! IBLAST=IROF KGPTRSEND(1,IBLOCK,IPROC)=IBFIRST KGPTRSEND(2,IBLOCK,IPROC)=IBLAST @@ -71,21 +76,13 @@ SUBROUTINE INIGPTR(KGPTRSEND,KGPTRRECV) ENDDO ENDDO IF(IROF /= 1.AND.IROF /= IBFIRST) THEN -! non-empty residual block after last latitude line + ! non-empty residual block after last latitude line IBLAST=IROF-1 KGPTRSEND(1,IBLOCK,IPROC)=IBFIRST KGPTRSEND(2,IBLOCK,IPROC)=IBLAST ENDIF ! sum up over blocks -KGPTRRECV(:)=0 -DO JPRTRNS=1,NPRTRNS - DO JBLKS=1,NGPBLKS - IF(KGPTRSEND(1,JBLKS,JPRTRNS) > 0) THEN - KGPTRRECV(JPRTRNS)=KGPTRRECV(JPRTRNS)+& - &KGPTRSEND(2,JBLKS,JPRTRNS)-KGPTRSEND(1,JBLKS,JPRTRNS)+1 - ENDIF - ENDDO -ENDDO +KGPTRRECV(:)=SUM(KGPTRSEND(2,:,:),1)-SUM(KGPTRSEND(1,:,:),1)+NGPBLKS END SUBROUTINE INIGPTR END MODULE INIGPTR_MOD diff --git a/src/trans/gpu/internal/inv_trans_ctl_mod.F90 b/src/trans/gpu/internal/inv_trans_ctl_mod.F90 index b3a49856d..a6ad97e1c 100755 --- a/src/trans/gpu/internal/inv_trans_ctl_mod.F90 +++ b/src/trans/gpu/internal/inv_trans_ctl_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2001- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -9,301 +10,231 @@ MODULE INV_TRANS_CTL_MOD CONTAINS -SUBROUTINE INV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& - & KF_UV,KF_SCALARS,KF_SCDERS,& - & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& - & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) - -!**** *INV_TRANS_CTL* - Control routine for inverse spectral transform. - -! Purpose. -! -------- -! Control routine for the inverse spectral transform - -!** Interface. -! ---------- -! CALL INV_TRANS_CTL(...) - -! Explicit arguments : -! -------------------- -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! KF_OUT_LT - total number of fields coming out from inverse LT -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! KF_SCDERS - local number of derivatives of scalar spectral fields -! PSPVOR(:,:) - spectral vorticity (input) -! PSPDIV(:,:) - spectral divergence (input) -! PSPSCALAR(:,:) - spectral scalarvalued fields (input) -! KVSETUV(:) - indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. -! KVESETSC(:) - indicating which 'b-set' in spectral space owns a -! scalar field. As for KVSETUV this argument is required -! if the total number of processors is greater than -! the number of processors used for distribution in -! spectral wave space. -! FSPGL_PROC - external procedure to be executed in fourier space -! before transposition -! PGP(:,:,:) - gridpoint fields (output) - -! The ordering of the output fields is as follows (all -! parts are optional depending on the input switches): - -! vorticity : KF_UV_G fields -! divergence : KF_UV_G fields -! u : KF_UV_G fields -! v : KF_UV_G fields -! scalar fields : KF_SCALARS_G fields -! N-S derivative of scalar fields : KF_SCALARS_G fields -! E-W derivative of u : KF_UV_G fields -! E-W derivative of v : KF_UV_G fields -! E-W derivative of scalar fields : KF_SCALARS_G fields - -! Method. -! ------- - -! Externals. SHUFFLE - reshuffle fields for load balancing -! ---------- FIELD_SPLIT - split fields in NPROMATR packets -! LTINV_CTL - control of Legendre transform -! FTINV_CTL - control of Fourier transform - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 01-01-03 - -! ------------------------------------------------------------------ - - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -USE TPM_GEN ,ONLY : NPROMATR -USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, FOUBUF -!USE TPM_DISTR - -USE SHUFFLE_MOD ,ONLY : SHUFFLE -USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT -USE LTINV_CTL_MOD ,ONLY : LTINV_CTL -USE FTINV_CTL_MOD ,ONLY : FTINV_CTL -use nvtx -! - -IMPLICIT NONE - -! Declaration of arguments - -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP -INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) -EXTERNAL FSPGL_PROC -OPTIONAL FSPGL_PROC -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) - -! Local variables - -INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) -INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) -INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) -INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G -INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP -INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT -INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB - -! ------------------------------------------------------------------ - -! Perform transform - -IF_GPB = 2*KF_UV_G+KF_SCALARS_G -IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN - - ! Fields to be split into packets - - CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& - & KVSETUV,KVSETSC) - - IBLKS=(IF_GPB-1)/NPROMATR+1 - - DO JBLK=1,IBLKS - - CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& - & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& - & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) - - IF(LSCDERS) THEN - IF_SCDERS = IF_SCALARS - ELSE - IF_SCDERS = 0 - ENDIF - - IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS - IF(LVORGP) THEN - IF_OUT_LT = IF_OUT_LT+IF_UV - ENDIF - IF(LDIVGP) THEN - IF_OUT_LT = IF_OUT_LT+IF_UV - ENDIF - IF_FS = IF_OUT_LT+IF_SCDERS - IF(LUVDER) THEN - IF_FS = IF_FS+2*IF_UV + SUBROUTINE INV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& + & KF_UV,KF_SCALARS,KF_SCDERS,& + & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& + & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) + + !**** *INV_TRANS_CTL* - Control routine for inverse spectral transform. + + ! Purpose. + ! -------- + ! Control routine for the inverse spectral transform + + !** Interface. + ! ---------- + ! CALL INV_TRANS_CTL(...) + + ! Explicit arguments : + ! -------------------- + ! KF_UV_G - global number of spectral u-v fields + ! KF_SCALARS_G - global number of scalar spectral fields + ! KF_GP - total number of output gridpoint fields + ! KF_FS - total number of fields in fourier space + ! KF_OUT_LT - total number of fields coming out from inverse LT + ! KF_UV - local number of spectral u-v fields + ! KF_SCALARS - local number of scalar spectral fields + ! KF_SCDERS - local number of derivatives of scalar spectral fields + ! PSPVOR(:,:) - spectral vorticity (input) + ! PSPDIV(:,:) - spectral divergence (input) + ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) + ! KVSETUV(:) - indicating which 'b-set' in spectral space owns a + ! vor/div field. Equivalant to NBSETLEV in the IFS. + ! The length of KVSETUV should be the GLOBAL number + ! of u/v fields which is the dimension of u and v releated + ! fields in grid-point space. + ! KVESETSC(:) - indicating which 'b-set' in spectral space owns a + ! scalar field. As for KVSETUV this argument is required + ! if the total number of processors is greater than + ! the number of processors used for distribution in + ! spectral wave space. + ! FSPGL_PROC - external procedure to be executed in fourier space + ! before transposition + ! PGP(:,:,:) - gridpoint fields (output) + + ! The ordering of the output fields is as follows (all + ! parts are optional depending on the input switches): + + ! vorticity : KF_UV_G fields + ! divergence : KF_UV_G fields + ! u : KF_UV_G fields + ! v : KF_UV_G fields + ! scalar fields : KF_SCALARS_G fields + ! N-S derivative of scalar fields : KF_SCALARS_G fields + ! E-W derivative of u : KF_UV_G fields + ! E-W derivative of v : KF_UV_G fields + ! E-W derivative of scalar fields : KF_SCALARS_G fields + + ! Method. + ! ------- + + ! Externals. SHUFFLE - reshuffle fields for load balancing + ! ---------- FIELD_SPLIT - split fields in NPROMATR packets + ! LTINV_CTL - control of Legendre transform + ! FTINV_CTL - control of Fourier transform + + ! Author. + ! ------- + ! Mats Hamrud *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 01-01-03 + + ! ------------------------------------------------------------------ + + + USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT, JPRD + + USE TPM_GEN ,ONLY : NPROMATR, NOUT + USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, REUSE_PTR + USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + USE ALLOCATOR_MOD + + USE TRMTOL_MOD + USE LTINV_MOD + USE TRMTOL_PACK_UNPACK + USE FSC_MOD + USE FTINV_MOD + USE TRLTOG_MOD + + IMPLICIT NONE + + ! Declaration of arguments + + INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G + INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G + INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT + INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV + INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS + INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) + REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) + EXTERNAL FSPGL_PROC + OPTIONAL FSPGL_PROC + REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) + REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) + REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) + REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) + + ! Local variables + + REAL(KIND=JPRB), POINTER :: FOUBUF(:), FOUBUF_IN(:) + REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:), PREEL_COMPLEX(:) + REAL(KIND=JPRBT), POINTER :: ZOUTS(:), ZOUTA(:) + REAL(KIND=JPRD), POINTER :: ZOUTS0(:), ZOUTA0(:) + INTEGER(KIND=JPIM) :: KUV_OFFSET, KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, & + & KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET + INTEGER(KIND=JPIM) :: IF_LEG, IF_FOURIER + + INTEGER(KIND=JPIM) :: IFIRST + + TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR + TYPE(LTINV_HANDLE) :: HLTINV + TYPE(TRMTOL_PACK_HANDLE) :: HTRMTOL_PACK + TYPE(TRMTOL_HANDLE) :: HTRMTOL + TYPE(TRMTOL_UNPACK_HANDLE) :: HTRMTOL_UNPACK + TYPE(FSC_HANDLE) :: HFSC + TYPE(FTINV_HANDLE) :: HFTINV + TYPE(TRLTOG_HANDLE) :: HTRLTOG + + INTEGER(KIND=C_INT8_T), POINTER :: PTR(:) + + ! ------------------------------------------------------------------ + + IF(NPROMATR > 0) THEN + print *, "This is currently not supported and/or tested (NPROMATR > 0j" + stop 24 ENDIF - IF_GP = 2*IF_UV_G+IF_SCALARS_G - IOFFD = 0 - IOFFU = 0 - IOFFV = KF_UV_G - IOFFUVD = 2*KF_UV_G+KF_SCALARS_G - IOFFSC = 2*KF_UV_G - IF(LVORGP) THEN - IF_GP = IF_GP+IF_UV_G - IOFFD = KF_UV_G - IOFFU = IOFFU+KF_UV_G - IOFFV = IOFFV+KF_UV_G - IOFFUVD =IOFFUVD+KF_UV_G - IOFFSC = IOFFSC+KF_UV_G + ! Compute Vertical domain decomposition + + ! Initialize potentially unset offsets + KSCALARS_NSDER_OFFSET = -1 + KUV_EWDER_OFFSET = -1 + KSCALARS_EWDER_OFFSET = -1 + + ! (note in ltinv we will initially start with a slightly different domain decomposition + ! which always has vorticity and divergence because this is the actual input) + IFIRST = 0 + IF (LVORGP) IFIRST = IFIRST + KF_UV ! Vorticity + IF (LDIVGP) IFIRST = IFIRST + KF_UV ! Divergence + KUV_OFFSET = IFIRST + IFIRST = IFIRST + KF_UV ! U + IFIRST = IFIRST + KF_UV ! V + KSCALARS_OFFSET = IFIRST + IFIRST = IFIRST + KF_SCALARS ! Scalars + IF (LSCDERS) THEN + KSCALARS_NSDER_OFFSET = IFIRST + IFIRST = IFIRST + KF_SCALARS ! Scalars NS Derivatives ENDIF - IF(LDIVGP) THEN - IF_GP = IF_GP+IF_UV_G - IOFFU = IOFFU+KF_UV_G - IOFFV = IOFFV+KF_UV_G - IOFFUVD =IOFFUVD+KF_UV_G - IOFFSC = IOFFSC+KF_UV_G + ! the rest of fields is being computed in fourier space, namely in FSC + IF_LEG = IFIRST + IF (LUVDER) THEN + KUV_EWDER_OFFSET = IFIRST + IFIRST = IFIRST+2*KF_UV ! U and V derivatives ENDIF - IF(LSCDERS) THEN - IF_GP = IF_GP+2*IF_SCALARS_G - IOFFUVD =IOFFUVD+KF_SCALARS_G - IOFFSCNS = IOFFSC+KF_SCALARS_G - IOFFSCEW = IOFFSC+2*KF_SCALARS_G + IF (LSCDERS) THEN + KSCALARS_EWDER_OFFSET = IFIRST + IFIRST = IFIRST + KF_SCALARS ! Scalars EW Derivatives ENDIF - IF(LUVDER) THEN - IF_GP = IF_GP+2*IF_UV_G - IOFFSCEW = IOFFSCEW+2*KF_UV_G + IF_FOURIER = IFIRST + IF (IF_FOURIER /= KF_FS) CALL ABORT_TRANS('Size mismatch: Wrong computation KF_FS') + + ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() + HLTINV = PREPARE_LTINV(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) + HTRMTOL_PACK = PREPARE_TRMTOL_PACK(ALLOCATOR,IF_LEG) + HTRMTOL = PREPARE_TRMTOL(ALLOCATOR,IF_LEG) + HTRMTOL_UNPACK = PREPARE_TRMTOL_UNPACK(ALLOCATOR,IF_FOURIER) + HFSC = PREPARE_FSC(ALLOCATOR) + HFTINV = PREPARE_FTINV(ALLOCATOR) + HTRLTOG = PREPARE_TRLTOG(ALLOCATOR,IF_FOURIER,KF_GP) + + CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, REUSE_PTR) + + IF (KF_FS > 0) THEN + ! Legendre transformations + CALL GSTATS(102,0) + CALL LTINV(ALLOCATOR,HLTINV,KF_UV,KF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & + & ZOUTS,ZOUTA,ZOUTS0,ZOUTA0) + CALL GSTATS(102,1) + + ! Packing into send buffer, to fourier space and unpack + CALL GSTATS(152,0) + CALL TRMTOL_PACK(ALLOCATOR,HTRMTOL_PACK,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,IF_LEG) + CALL TRMTOL_CUDAAWARE(ALLOCATOR,HTRMTOL,FOUBUF_IN,FOUBUF,IF_LEG) + CALL TRMTOL_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL_COMPLEX,IF_LEG,IF_FOURIER) + CALL GSTATS(152,1) + + CALL GSTATS(107,0) + ! compute NS derivatives + CALL FSC(ALLOCATOR,HFSC,PREEL_COMPLEX, IF_FOURIER, KF_UV, KF_SCALARS, KUV_OFFSET, KSCALARS_OFFSET, & + & KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET) + !Legendre transformations + CALL FTINV(ALLOCATOR, HFTINV, PREEL_COMPLEX,PREEL_REAL,IF_FOURIER) + CALL GSTATS(107,1) ENDIF - DO JFLD=1,IF_UV_G - IOFF = 0 - IF(LVORGP) THEN - IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - ENDIF - IF(LDIVGP) THEN - IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - ENDIF - IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G+IF_SCALARS_G - IF(LSCDERS) THEN - IOFF = IOFF+IF_SCALARS_G - ENDIF - IF(LUVDER) THEN - IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) - ENDIF - ENDDO - - DO JFLD=1,IF_SCALARS_G - IOFF = 2*IF_UV_G - IF (LVORGP) IOFF = IOFF+IF_UV_G - IF (LDIVGP) IOFF = IOFF+IF_UV_G - IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) - IOFF = IOFF+IF_SCALARS_G - IF(LSCDERS) THEN - IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) - IOFF = IOFF+IF_SCALARS_G - IF(LUVDER) THEN - IOFF = IOFF+2*IF_UV_G - ENDIF - IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) - ENDIF - ENDDO - DO JFLD=1,IF_UV - IPTRSPUV(JFLD) = ISTUV+JFLD-1 - ENDDO - DO JFLD=1,IF_SCALARS - IPTRSPSC(JFLD) = ISTSC+JFLD-1 - ENDDO - - CALL LTINV_CTL(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & - & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,FSPGL_PROC=FSPGL_PROC) - - IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN - CALL FTINV_CTL(IF_UV_G,IF_SCALARS_G,& - & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& - & PGP=PGP) - ELSEIF(IF_UV_G > 0) THEN - CALL FTINV_CTL(IF_UV_G,IF_SCALARS_G,& - & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),KPTRGP=IPTRGP,& - & PGP=PGP) - ELSEIF(IF_SCALARS_G > 0) THEN - CALL FTINV_CTL(IF_UV_G,IF_SCALARS_G,& - & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& - & PGP=PGP) - ENDIF - ENDDO - -ELSE - call nvtxStartRange("INVTRANS") - - !$ACC DATA CREATE(FOUBUF) - ! No splitting of fields, transform done in one go - ! from PSPXXX to FOUBUF - call nvtxStartRange("LTINV") - CALL LTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & - &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& - &FSPGL_PROC=FSPGL_PROC) - call nvtxEndRange - - ! from FOUBUF to PGPXXX - call nvtxStartRange("FTINV") - CALL FTINV_CTL(KF_UV_G,KF_SCALARS_G,& - & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& - & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& - & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& - & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) - !$ACC END DATA - call nvtxEndRange - - call nvtxEndRange - -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE INV_TRANS_CTL + ! Transposition into grid-point space + CALL GSTATS(157,0) + CALL TRLTOG_CUDAAWARE(ALLOCATOR,HTRLTOG,PREEL_REAL,IF_FOURIER,KF_GP,KF_UV_G,KF_SCALARS_G,& + & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& + & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& + & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) + CALL GSTATS(157,1) + + END SUBROUTINE INV_TRANS_CTL END MODULE INV_TRANS_CTL_MOD diff --git a/src/trans/gpu/internal/inv_trans_ctlad_mod.F90 b/src/trans/gpu/internal/inv_trans_ctlad_mod.F90 deleted file mode 100755 index b1729fe92..000000000 --- a/src/trans/gpu/internal/inv_trans_ctlad_mod.F90 +++ /dev/null @@ -1,295 +0,0 @@ -! (C) Copyright 2001- 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 INV_TRANS_CTLAD_MOD -CONTAINS -SUBROUTINE INV_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& - & KF_UV,KF_SCALARS,KF_SCDERS,& - & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& - & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) - -!**** *INV_TRANS_CTLAD* - Control routine for inverse spectral transform adj. - -! Purpose. -! -------- -! Control routine for the inverse spectral transform - -!** Interface. -! ---------- -! CALL INV_TRANS_CTLAD(...) - -! Explicit arguments : -! -------------------- -! KF_UV_G - global number of spectral u-v fields -! KF_SCALARS_G - global number of scalar spectral fields -! KF_GP - total number of output gridpoint fields -! KF_FS - total number of fields in fourier space -! KF_OUT_LT - total number of fields coming out from inverse LT -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! KF_SCDERS - local number of derivatives of scalar spectral fields -! PSPVOR(:,:) - spectral vorticity (input) -! PSPDIV(:,:) - spectral divergence (input) -! PSPSCALAR(:,:) - spectral scalarvalued fields (input) -! KVSETUV(:) - indicating which 'b-set' in spectral space owns a -! vor/div field. Equivalant to NBSETLEV in the IFS. -! The length of KVSETUV should be the GLOBAL number -! of u/v fields which is the dimension of u and v releated -! fields in grid-point space. -! KVESETSC(:) - indicating which 'b-set' in spectral space owns a -! scalar field. As for KVSETUV this argument is required -! if the total number of processors is greater than -! the number of processors used for distribution in -! spectral wave space. -! PGP(:,:,:) - gridpoint fields (output) - -! The ordering of the output fields is as follows (all -! parts are optional depending on the input switches): -! -! vorticity : KF_UV_G fields -! divergence : KF_UV_G fields -! u : KF_UV_G fields -! v : KF_UV_G fields -! scalar fields : KF_SCALARS_G fields -! N-S derivative of scalar fields : KF_SCALARS_G fields -! E-W derivative of u : KF_UV_G fields -! E-W derivative of v : KF_UV_G fields -! E-W derivative of scalar fields : KF_SCALARS_G fields -! -! Method. -! ------- - -! Externals. SHUFFLE - reshuffle fields for load balancing -! ---------- FIELD_SPLIT - split fields in NPROMATR packets -! LTINV_CTLAD - control of Legendre transform -! FTINV_CTLAD - control of Fourier transform - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 01-01-03 - -! ------------------------------------------------------------------ - - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -USE TPM_GEN ,ONLY : NPROMATR -USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP -!USE TPM_DISTR - -USE SHUFFLE_MOD ,ONLY : SHUFFLE -USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT -USE LTINV_CTLAD_MOD ,ONLY : LTINV_CTLAD -USE FTINV_CTLAD_MOD ,ONLY : FTINV_CTLAD -! - -IMPLICIT NONE - -! Declaration of arguments - -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G -INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP -INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) -INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPUV(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3A(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP3B(:,:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGP2(:,:,:) - -! Local variables - -INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) -INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) -INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) -INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G -INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP -INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT -INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB - -! ------------------------------------------------------------------ - -! Perform transform - - -IF_GPB = 2*KF_UV_G+KF_SCALARS_G -IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN - - ! Fields to be split into packets - - CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& - & KVSETUV,KVSETSC) - - IBLKS=(IF_GPB-1)/NPROMATR+1 - - DO JBLK=1,IBLKS - - CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& - & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& - & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) - - IF(LSCDERS) THEN - IF_SCDERS = IF_SCALARS - ELSE - IF_SCDERS = 0 - ENDIF - - IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS - IF(LVORGP) THEN - IF_OUT_LT = IF_OUT_LT+IF_UV - ENDIF - IF(LDIVGP) THEN - IF_OUT_LT = IF_OUT_LT+IF_UV - ENDIF - IF_FS = IF_OUT_LT+IF_SCDERS - IF(LUVDER) THEN - IF_FS = IF_FS+2*IF_UV - ENDIF - - IF_GP = 2*IF_UV_G+IF_SCALARS_G - IOFFD = 0 - IOFFU = 0 - IOFFV = KF_UV_G - IOFFUVD = 2*KF_UV_G+KF_SCALARS_G - IOFFSC = 2*KF_UV_G - IF(LVORGP) THEN - IF_GP = IF_GP+IF_UV_G - IOFFD = KF_UV_G - IOFFU = IOFFU+KF_UV_G - IOFFV = IOFFV+KF_UV_G - IOFFUVD =IOFFUVD+KF_UV_G - IOFFSC = IOFFSC+KF_UV_G - ENDIF - IF(LDIVGP) THEN - IF_GP = IF_GP+IF_UV_G - IOFFU = IOFFU+KF_UV_G - IOFFV = IOFFV+KF_UV_G - IOFFUVD =IOFFUVD+KF_UV_G - IOFFSC = IOFFSC+KF_UV_G - ENDIF - IF(LSCDERS) THEN - IF_GP = IF_GP+2*IF_SCALARS_G - IOFFUVD =IOFFUVD+KF_SCALARS_G - IOFFSCNS = IOFFSC+KF_SCALARS_G - IOFFSCEW = IOFFSC+2*KF_SCALARS_G - ENDIF - IF(LUVDER) THEN - IF_GP = IF_GP+2*IF_UV_G - IOFFSCEW = IOFFSCEW+2*KF_UV_G - ENDIF - - DO JFLD=1,IF_UV_G - IOFF = 0 - IF(LVORGP) THEN - IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - ENDIF - IF(LDIVGP) THEN - IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - ENDIF - IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G+IF_SCALARS_G - IF(LSCDERS) THEN - IOFF = IOFF+IF_SCALARS_G - ENDIF - IF(LUVDER) THEN - IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) - IOFF = IOFF+IF_UV_G - IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) - ENDIF - ENDDO - - DO JFLD=1,IF_SCALARS_G - IOFF = 2*IF_UV_G - IF (LVORGP) IOFF = IOFF+IF_UV_G - IF (LDIVGP) IOFF = IOFF+IF_UV_G - IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) - IOFF = IOFF+IF_SCALARS_G - IF(LSCDERS) THEN - IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) - IOFF = IOFF+IF_SCALARS_G - IF(LUVDER) THEN - IOFF = IOFF+2*IF_UV_G - ENDIF - IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) - ENDIF - ENDDO - DO JFLD=1,IF_UV - IPTRSPUV(JFLD) = ISTUV+JFLD-1 - ENDDO - DO JFLD=1,IF_SCALARS - IPTRSPSC(JFLD) = ISTSC+JFLD-1 - ENDDO - - IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN - CALL FTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& - & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& - & PGP=PGP) - ELSEIF(IF_UV_G > 0) THEN - CALL FTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& - & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& - & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& - & KPTRGP=IPTRGP,& - & PGP=PGP) - ELSEIF(IF_SCALARS_G > 0) THEN - CALL FTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& - & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& - & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& - & PGP=PGP) - ENDIF - CALL LTINV_CTLAD(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & - & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC) - - ENDDO - -ELSE - - ! No splitting of fields, transform done in one go - - CALL FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& - & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& - & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& - & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& - & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) - - CALL LTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & - &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& - &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2) - -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE INV_TRANS_CTLAD -END MODULE INV_TRANS_CTLAD_MOD diff --git a/src/trans/gpu/internal/ldfou2_mod.F90 b/src/trans/gpu/internal/ldfou2_mod.F90 deleted file mode 100755 index d2ba772f6..000000000 --- a/src/trans/gpu/internal/ldfou2_mod.F90 +++ /dev/null @@ -1,115 +0,0 @@ -! (C) Copyright 1991- 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 LDFOU2_MOD -CONTAINS -SUBROUTINE LDFOU2(KF_UV,PAIA) - -!**** *LDFOU2* - Division by a*cos(theta) of u and v - -! Purpose. -! -------- -! In Fourier space divide u and v by a*cos(theta). - -!** Interface. -! ---------- -! CALL LDFOU2(KM,PAIA,PSIA) - -! Explicit arguments : -! -------------------- KM - zonal wavenumber -! PAIA - antisymmetric fourier fields -! PSIA - symmetric fourierfields - -! Implicit arguments : RACTHE - 1./(a*cos(theta)) -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS -! Temperton, 1991, MWR 119 p1303 - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 91-07-01 -! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' -! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div -! instead of u,v->vor,div -! MPP Group: 95-10-01 Message Passing option added -! Modified : 04/06/99 D.Salmond : change order of AIA and SIA -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_FIELDS ,ONLY : F -USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS -USE TPM_DIM ,ONLY : R, R_NDGNH, R_NDGL -USE TPM_GEOMETRY ,ONLY : G, G_NDGLU - -! - -IMPLICIT NONE - - -! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM) :: KM,KMLOC - -REAL(KIND=JPRBT) ,INTENT(INOUT) :: PAIA(:,:,:) -!REAL(KIND=JPRBT) ,INTENT(INOUT) :: PSIA(:,:,:), PAIA(:,:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: J, JGL ,IFLD ,ISL, IGLS - -! ------------------------------------------------------------------ - -!* 1. DIVIDE U V BY A*COS(THETA) -! -------------------------- - -IFLD = 4*KF_UV -IF( IFLD > 0 ) THEN - -!$ACC DATA & -!$ACC& PRESENT(F,F%RACTHE,D,D_NUMP,D_MYMS,R_NDGNH,R_NDGL,G_NDGLU) & -!$ACC& PRESENT(PAIA) - -!loop over wavenumber - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,ISL,IGLS) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO JGL=1,R_NDGNH - DO J=1,4*KF_UV - KM = D_MYMS(KMLOC) - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) -!* 1.1 U AND V - if (JGL .ge. ISL) then - IGLS = R_NDGL+1-JGL - PAIA(J,JGL,KMLOC) = PAIA(J,JGL,KMLOC)*F%RACTHE(JGL) -! PSIA(J,JGL,KMLOC) = PSIA(J,JGL,KMLOC)*F%RACTHE(JGL) - endif - ENDDO - ENDDO -ENDDO -!$ACC END DATA - -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE LDFOU2 -END MODULE LDFOU2_MOD diff --git a/src/trans/gpu/internal/ldfou2ad_mod.F90 b/src/trans/gpu/internal/ldfou2ad_mod.F90 deleted file mode 100755 index 0763a2571..000000000 --- a/src/trans/gpu/internal/ldfou2ad_mod.F90 +++ /dev/null @@ -1,96 +0,0 @@ -! (C) Copyright 1991- 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 LDFOU2AD_MOD -CONTAINS -SUBROUTINE LDFOU2AD(KM,KF_UV,PAIA,PSIA) - -!**** *LDFOU2AD* - Division by a*cos(theta) of u and v - -! Purpose. -! -------- -! In Fourier space divide u and v by a*cos(theta). - -!** Interface. -! ---------- -! CALL LDFOU2AD(KM,PAIA,PSIA) - -! Explicit arguments : -! -------------------- KM - zonal wavenumber -! PAIA - antisymmetric fourier fields -! PSIA - symmetric fourierfields - -! Implicit arguments : RACTHE - 1./(a*cos(theta)) -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS -! Temperton, 1991, MWR 119 p1303 - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 91-07-01 -! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' -! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div -! instead of u,v->vor,div -! MPP Group: 95-10-01 Message Passing option added -! Modified : 04/06/99 D.Salmond : change order of AIA and SIA -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_GEOMETRY ,ONLY : G -USE TPM_FIELDS ,ONLY : F -! - -IMPLICIT NONE - - -! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV - -REAL(KIND=JPRBT) ,INTENT(INOUT) :: PSIA(:,:), PAIA(:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: J, JGL ,IFLD ,ISL - - -! ------------------------------------------------------------------ - -!* 1. DIVIDE U V BY A*COS(THETA) -! -------------------------- - -ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) -IFLD = 4*KF_UV - -!* 1.1 U AND V - -DO JGL=ISL,R%NDGNH - DO J=1,IFLD - PAIA(J,JGL) = PAIA(J,JGL)*F%RACTHE(JGL) - PSIA(J,JGL) = PSIA(J,JGL)*F%RACTHE(JGL) - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE LDFOU2AD -END MODULE LDFOU2AD_MOD diff --git a/src/trans/gpu/internal/ledir_mod.F90 b/src/trans/gpu/internal/ledir_mod.F90 index 23de16dd3..4f7954e6d 100755 --- a/src/trans/gpu/internal/ledir_mod.F90 +++ b/src/trans/gpu/internal/ledir_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,344 +10,299 @@ ! MODULE LEDIR_MOD + USE PARKIND_ECTRANS ,ONLY : JPIM + USE TPM_TRANS, ONLY: LEDIR_CONFIG + IMPLICIT NONE + + PRIVATE + PUBLIC :: LEDIR_STRIDES, LEDIR + + INTEGER(KIND=JPIM) :: A = 8 !Alignment CONTAINS -SUBROUTINE LEDIR(KF_FS,KLED2,PAIA,POA1,KMODE) - -!**** *LEDIR* - Direct Legendre transform. - -! Purpose. -! -------- -! Direct Legendre tranform of state variables. - -!** Interface. -! ---------- -! CALL LEDIR(...) - -! Explicit arguments : KM - zonal wavenumber -! -------------------- KFC - number of field to transform -! PAIA - antisymmetric part of Fourier -! fields for zonal wavenumber KM -! PSIA - symmetric part of Fourier -! fields for zonal wavenumber KM -! POA1 - spectral -! fields for zonal wavenumber KM - -! Implicit arguments : None. -! -------------------- - -! Method. -! ------- use butterfly or dgemm - -! Externals. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Nils Wedi + Mats Hamrud + George Modzynski - -! Modifications. -! -------------- -! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: -! F. Vana 05-Mar-2015 Support for single precision -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPIB ,JPRB, JPRBT -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK -USE TPM_DIM ,ONLY : R, R_NDGNH,R_NSMAX,R_NTMAX -USE TPM_GEOMETRY ,ONLY : G, G_NDGLU -USE TPM_FIELDS ,ONLY : F, & - & ZAA,ZAS,LDZAA,LDZAS,TDZAA,TDZAS,& - & DZBST,DLDZBA,DLDZBS,DTDZBA,DTDZBS,& - & DZCST,DZCAT,DLDZCA,DLDZCS,DTDZCA,DTDZCS,& - & ZAMAX, ZSMAX,& - & IF_FS_DIR,ZAA0,DZBST0,DZCAT0,ZAS0,DZCST0,KMLOC0 -USE TPM_DISTR -USE TPM_GEN, ONLY: NOUT -USE TPM_FLT -USE BUTTERFLY_ALG_MOD -USE CUDA_GEMM_BATCHED_MOD!!, ONLY: CUDA_TCGEMM_BATCHED, CUDA_GEMM_BATCHED -USE CUBLAS_MOD, ONLY : CUDA_DGEMM_BATCHED -USE, INTRINSIC :: ISO_C_BINDING -USE IEEE_ARITHMETIC - -IMPLICIT NONE - - -! DUMMY ARGUMENTS -INTEGER(KIND=JPIM) :: KM -INTEGER(KIND=JPIM) :: KMLOC -INTEGER(KIND=JPIM) :: KFC -INTEGER(KIND=JPIM) :: KIFC -INTEGER(KIND=JPIM) :: KDGLU -INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS -INTEGER(KIND=JPIM), INTENT(IN) :: KLED2 -INTEGER(KIND=JPIM), INTENT(IN) :: KMODE - -REAL(KIND=JPRBT), INTENT(IN) :: PAIA(:,:,:) -!REAL(KIND=JPRBT), INTENT(IN) :: PSIA(:,:,:), PAIA(:,:,:) -REAL(KIND=JPRBT), INTENT(OUT) :: POA1(:,:,:) - -! LOCAL VARIABLES -INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, IF, J, JK, IRET -INTEGER(KIND=JPIM) :: ITHRESHOLD -REAL(KIND=JPRB) :: RRPELTMDIR = 100.0_JPRB -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -INTEGER :: ISTAT - -IF (LHOOK) CALL DR_HOOK('LE_DGEMM',0,ZHOOK_HANDLE) - -KFC = 2*KF_FS -KIFC = KFC - -!$ACC DATA & -!$ACC& PRESENT(F,F%RW) & -!$ACC& PRESENT(D,D_NUMP,D_MYMS,R,R_NDGNH,G,G_NDGLU,R_NSMAX,R_NTMAX) & -!$ACC& PRESENT(PAIA) & -!$ACC& PRESENT(ZAA,ZAS,DZBST,DZCST,DZCAT) & -!$ACC& PRESENT(POA1,dzbst0,dzcat0,dzbst0,dzcst0) !& - - -!! Initialize rescaling arrays to zero -!!$ACC PARALLEL LOOP COLLAPSE(2) -!DO KMLOC=1,SIZE(ZAMAX,2) -! DO JK=1,SIZE(ZAMAX,1) -! ZAMAX(JK,KMLOC) = 0.0_JPRBT -! ZSMAX(JK,KMLOC) = 0.0_JPRBT -! ENDDO -!ENDDO - - -! anti-symmetric - -IF ( KMODE == -1 ) THEN - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,KDGLU,ISL,ISKIP) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,R_NDGNH - DO JK=1,KFC - - KM = D_MYMS(KMLOC) - KDGLU = MIN(R_NDGNH,G_NDGLU(KM)) - IF (J .LE. KDGLU) THEN - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) - - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - !DZBST((JK-1)/ISKIP+1+(J-1+(KMLOC-1)*R_NDGNH)*IF_FS_DIR)=PAIA(JK,ISL+J-1,KMLOC)*F%RW(ISL+J-1) - DZBST((JK-1)/ISKIP+1+(J-1+(KMLOC-1)*DLDZBA)*DTDZBA)=PAIA(JK,ISL+J-1,KMLOC)*F%RW(ISL+J-1) - END IF - END IF - ENDDO - ENDDO -END DO - - -! Get C in transpose format to get better memory access patterns later -!C=A*B => -! C^T=B^T*A^T -!$ACC HOST_DATA USE_DEVICE(ZAA,DZBST,DZCAT) -CALL CUDA_GEMM_BATCHED( & - & 'N', 'N', & - & DTDZBA, TDZAA, DLDZBA, & - & 1.0_JPRBT, & - & DZBST, DTDZBA, DLDZBA, & - & ZAA, LDZAA, TDZAA, & - & 0._JPRBT, & - & DZCAT, DTDZCA, DLDZCA, & - & D_NUMP) -!$ACC END HOST_DATA - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,ISKIP,ILA,IA,ILS) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,(R_NTMAX+2)/2 - DO JK=1,KFC - - KM = D_MYMS(KMLOC) - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - ILA = (R_NTMAX-KM+2)/2 - IA = 1+MOD(R_NTMAX-KM+2,2) - IF (J .LE. ILA) THEN - POA1(JK,IA+(J-1)*2,KMLOC) = DZCAT((JK-1)/ISKIP+1+(J-1+(KMLOC-1)*DLDZCA)*DTDZCA) - END IF - END IF - ENDDO - ENDDO -ENDDO - -! compute m=0 in double precision: -IF(KMLOC0 > 0) THEN - print*,'computing m=0 in double precision' - ISKIP = 2 - - !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,KDGLU,ISL,ISKIP) DEFAULT(NONE) - DO J=1,R_NDGNH - DO JK=1,KFC - - KDGLU = MIN(R_NDGNH,G_NDGLU(0)) - IF (J .LE. KDGLU) THEN - ISL = MAX(R_NDGNH-G_NDGLU(0)+1,1) - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - DZBST0((JK-1)/ISKIP+1+(J-1)*DTDZBA)=PAIA(JK,ISL+J-1,KMLOC0)*F%RW(ISL+J-1) - END IF - END IF + SUBROUTINE LEDIR_STRIDES(KF_FS,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& + IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT, JPRD + USE TPM_DIM ,ONLY : R + USE TPM_DISTR, ONLY: D,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2 + + IMPLICIT NONE + + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + + INTEGER(KIND=JPIM), OPTIONAL :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM), OPTIONAL :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM), OPTIONAL :: IOUT0_STRIDES0, IOUT0_SIZE + INTEGER(KIND=JPIM), OPTIONAL :: IIN0_STRIDES0, IIN0_SIZE + + IF (PRESENT(IOUT_STRIDES0)) & + IOUT_STRIDES0 = ALIGN(2*KF_FS,A) + IF (PRESENT(IOUT_SIZE)) & + IOUT_SIZE = IOUT_STRIDES0*D_OFFSETS_GEMM2(D%NUMP+1) + IF (PRESENT(IIN_STRIDES0)) & + IIN_STRIDES0 = ALIGN(2*KF_FS,A) + IF (PRESENT(IIN_SIZE)) & + IIN_SIZE = IIN_STRIDES0*D_OFFSETS_GEMM1(D%NUMP+1) + IF (PRESENT(IOUT0_STRIDES0)) & + IOUT0_STRIDES0 = ALIGN(KF_FS,A) + IF (PRESENT(IOUT0_SIZE)) & + IOUT0_SIZE = IOUT0_STRIDES0 * ALIGN(MAX((R%NTMAX+2)/2,(R%NTMAX+3)/2),A) + IF (PRESENT(IIN0_STRIDES0)) & + IIN0_STRIDES0 = ALIGN(KF_FS,A) + IF (PRESENT(IIN0_SIZE)) & + IIN0_SIZE = IIN0_STRIDES0 * ALIGN(R%NDGNH,A) + END SUBROUTINE + + SUBROUTINE LEDIR(ZINPS,ZINPA,ZINPS0,ZINPA0,ZOUT,ZOUT0,POA1,KF_FS) + !**** *LEDIR* - Direct Legendre transform. + + ! Purpose. + ! -------- + ! Direct Legendre tranform of state variables. + + !** Interface. + ! ---------- + ! CALL LEDIR(...) + + ! Explicit arguments : KM - zonal wavenumber + ! -------------------- KFC - number of field to transform + ! fields for zonal wavenumber KM + ! PSIA - symmetric part of Fourier + ! fields for zonal wavenumber KM + ! POA1 - spectral + ! fields for zonal wavenumber KM + + ! Implicit arguments : None. + ! -------------------- + + ! Method. + ! ------- use butterfly or dgemm + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! Nils Wedi + Mats Hamrud + George Modzynski + + ! Modifications. + ! -------------- + ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: + ! F. Vana 05-Mar-2015 Support for single precision + ! ------------------------------------------------------------------ + + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT, JPRD + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE TPM_DIM ,ONLY : R, R_NDGNH,R_NSMAX,R_NTMAX,R_NDGL + USE TPM_GEOMETRY ,ONLY : G, G_NDGLU + USE TPM_FIELDS ,ONLY : F,ZAA,ZAS,ZAA0,ZAS0,KMLOC0 + USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2 + USE CUDA_GEMM_BATCHED_MOD + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + USE, INTRINSIC :: ISO_C_BINDING + USE IEEE_ARITHMETIC + USE OPENACC + + + IMPLICIT NONE + + ! DUMMY ARGUMENTS + REAL(KIND=JPRBT), INTENT(IN) :: ZINPS(:), ZINPA(:) + REAL(KIND=JPRD), INTENT(IN) :: ZINPS0(:), ZINPA0(:) + REAL(KIND=JPRBT), INTENT(INOUT) :: ZOUT(:) + REAL(KIND=JPRD), INTENT(INOUT) :: ZOUT0(:) + REAL(KIND=JPRBT), INTENT(OUT), POINTER :: POA1(:,:,:) + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + + ! LOCAL VARIABLES + INTEGER(KIND=JPIM) :: KM + INTEGER(KIND=JPIM) :: KMLOC + INTEGER(KIND=JPIM) :: IA, IS, ISL, J + INTEGER(KIND=JPIM) :: KS(D_NUMP), NS(D_NUMP), AOFFSETS(D_NUMP), BOFFSETS(D_NUMP), COFFSETS(D_NUMP) + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + REAL(KIND=JPRBT) :: PAIA, PAIS, V1, V2 + + INTEGER(KIND=JPIM) :: IGLS, JF, JGL + INTEGER(KIND=JPIM) :: OFFSET1, OFFSET2 + + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_STRIDES1 + INTEGER(KIND=JPIM) :: IIN_STRIDES0, IIN_STRIDES1 + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_STRIDES1 + INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_STRIDES1 + INTEGER(KIND=8) :: ALLOC_SZ, ALLOC_POS + + IF (LHOOK) CALL DR_HOOK('LE_DGEMM',0,ZHOOK_HANDLE) + + CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0,IOUT_STRIDES1,IIN_STRIDES0,IIN_STRIDES1,& + IOUT0_STRIDES0,IOUT0_STRIDES1,IIN0_STRIDES0,IIN0_STRIDES1) + + !$ACC DATA & + !$ACC& PRESENT(ZINPS,ZINPA,ZOUT,ZINPS0,ZINPA0,ZOUT0) & + !$ACC& PRESENT(F,F%RW) & + !$ACC& PRESENT(D,D_MYMS,R,G,G_NDGLU) & + !$ACC& PRESENT(ZAA,ZAS,POA1,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2) + + ! anti-symmetric + IF(KMLOC0 > 0) THEN + PRINT*,'computing m=0 in double precision' + ENDIF + + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) + ENDIF + CALL GSTATS(414,0) + + IF(KMLOC0 > 0) THEN + ! compute m=0 in double precision: + CALL CUDA_GEMM_BATCHED( & + & CUBLAS_OP_N, CUBLAS_OP_N, & + & KF_FS, (R%NSMAX+2)/2, G%NDGLU(0), & + & 1.0_JPRD, & + & ZINPA0, IIN0_STRIDES0, 0, & + & ZAA0, SIZE(ZAA0,1), 0, & + & 0.0_JPRD, & + & ZOUT0, IOUT0_STRIDES0, 0, & + & 1, STREAM=1_C_LONG) + ENDIF + ! Get C in transpose format to get better memory access patterns later + !C=A*B => + ! C^T=B^T*A^T + DO KMLOC=1,D_NUMP + KM = D_MYMS(KMLOC) + NS(KMLOC) = (R%NSMAX-KM+2)/2 + KS(KMLOC) = G%NDGLU(KM) + AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC) + BOFFSETS(KMLOC) = SIZE(ZAA,1)*SIZE(ZAA,2)*(KMLOC-1) + COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM2(KMLOC) ENDDO - ENDDO - - - ! Get C in transpose format to get better memory access patterns later - !C=A*B => - ! C^T=B^T*A^T - - !$ACC HOST_DATA USE_DEVICE(ZAA0,DZBST0,DZCAT0) - CALL CUDA_DGEMM_BATCHED('N','N',DTDZBA,int(TDZAA,kind=jpim),int(DLDZBA,kind=jpim), & - & 1.0_JPRD,DZBST0,DTDZBA,int(DLDZBA,kind=jpim),& - & ZAA0,LDZAA,int(TDZAA,kind=jpim),0._JPRD,DZCAT0,DTDZCA,int(DLDZCA,kind=jpim),1) - !call CUDA_DGEMM('N','N',DTDZBA,TDZAA,DLDZBA,1.0_JPRD,DZBST0,DTDZBA,& - ! &ZAA0,LDZAA,0._JPRD,DZCAT0,DTDZCA) - !$ACC END HOST_DATA - - !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(ILA,IA,ILS) DEFAULT(NONE) - DO J=1,(R_NTMAX+2)/2 - DO JK=1,KFC - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - ILA = (R_NTMAX+2)/2 - IA = 1+MOD(R_NTMAX+2,2) - IF (J .LE. ILA) THEN - POA1(JK,IA+(J-1)*2,KMLOC0) = DZCAT0((JK-1)/ISKIP+1+(J-1)*DTDZCA) - END IF - END IF - ENDDO -ENDDO -ENDIF - -ELSE - -! symmetric - -!$acc parallel loop collapse(3) private(KM,KDGLU,ISL,ISKIP) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,R_NDGNH - DO JK=1,KFC - KM = D_MYMS(KMLOC) - KDGLU = MIN(R_NDGNH,G_NDGLU(KM)) - IF (J .LE. KDGLU) THEN - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) - - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN -! DZBST((JK-1)/ISKIP+1,J,KMLOC)=PSIA(JK,ISL+J-1,KMLOC)*F%RW(ISL+J-1) - DZBST((JK-1)/ISKIP+1+(J-1+(KMLOC-1)*DLDZBS)*DTDZBS)=PAIA(JK,ISL+J-1,KMLOC)*F%RW(ISL+J-1) - END IF - END IF - ENDDO - ENDDO -END DO - -! Get C in transpose format to get better memory access patterns later -!C=A*B => -! C^T=B^T*A^T -!$ACC HOST_DATA USE_DEVICE(ZAS,DZBST,DZCST) -CALL CUDA_GEMM_BATCHED( & - & 'N', 'N', & - & DTDZBS, TDZAS, DLDZBS, & - & 1.0_JPRBT, & - & DZBST, DTDZBS, DLDZBS, & - & ZAS, LDZAS, TDZAS, & - & 0._JPRBT, & - & DZCST, DTDZCS, DLDZCS, & - & D_NUMP) -!$ACC END HOST_DATA - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,ISKIP,ILA,IA,ILS,IS) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,(R_NTMAX+3)/2 - DO JK=1,KFC - - KM = D_MYMS(KMLOC) - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - ILS = (R_NTMAX-KM+3)/2 - IF (J .LE. ILS) THEN - IS = 1+MOD(R_NTMAX-KM+1,2) - POA1(JK,IS+(J-1)*2,KMLOC) = DZCST((JK-1)/ISKIP+1+(J-1+(KMLOC-1)*DLDZCS)*DTDZCS) - END IF - END IF - ENDDO - ENDDO -ENDDO - -IF(KMLOC0 > 0) THEN - !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KDGLU,ISL) DEFAULT(NONE) - DO J=1,R_NDGNH - DO JK=1,KFC - KDGLU = MIN(R_NDGNH,G_NDGLU(0)) - IF (J .LE. KDGLU) THEN - ISL = MAX(R_NDGNH-G_NDGLU(0)+1,1) - IF (MOD((JK-1),ISKIP) .eq. 0) THEN - DZBST0((JK-1)/ISKIP+1+(J-1)*DTDZBS)=PAIA(JK,ISL+J-1,KMLOC0)*F%RW(ISL+J-1) - END IF - END IF - ENDDO - ENDDO - - ! Get C in transpose format to get better memory access patterns later - !C=A*B => - ! C^T=B^T*A^T - - !$ACC host_data use_device(ZAS0,DZBST0,DZCST0) - call CUDA_DGEMM_BATCHED('N','N',& - & DTDZBS,TDZAS,DLDZBS,& - & 1.0_JPRD,DZBST0,DTDZBS,DLDZBS,& - & ZAS0,LDZAS,TDZAS,& - & 0._JPRD,DZCST0,DTDZCS,DLDZCS,1) - !$ACC end host_data - - !$ACC parallel loop collapse(2) private(ILA,IA,ILS,IS) DEFAULT(NONE) - DO J=1,(R_NTMAX+3)/2 - DO JK=1,KFC - if (MOD((JK-1),ISKIP) .eq. 0) then - ILS = (R_NTMAX+3)/2 - if (J .le. ILS) then - IS = 1+MOD(R_NTMAX+1,2) - POA1(JK,IS+(J-1)*2,KMLOC0) = DZCST0((JK-1)/ISKIP+1+(J-1)*DTDZCS) - end if - end if + IF(KMLOC0 > 0) THEN + NS(KMLOC0) = 0 + KS(KMLOC0) = 0 + ENDIF + CALL CUDA_GEMM_BATCHED( & + & 21, & ! unique identifier + & CUBLAS_OP_N, CUBLAS_OP_N, & + & 2*KF_FS, NS(:), KS(:), & + & 1.0_JPRBT, & + & ZINPA, IIN_STRIDES0, AOFFSETS, & + & ZAA, SIZE(ZAA,1), BOFFSETS, & + & 0.0_JPRBT, & + & ZOUT, IOUT_STRIDES0, COFFSETS, & + & D_NUMP, STREAM=1_C_LONG) + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(434,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(434,1) + ENDIF + CALL GSTATS(414,1) + + !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IA,J) DEFAULT(NONE) ASYNC(1) + DO KMLOC=1,D_NUMP + DO JF=1,2*KF_FS + KM = D_MYMS(KMLOC) + IA = 1+MOD(R_NTMAX-KM+2,2) + IF (KM /= 0) THEN + !$ACC LOOP SEQ + DO J=1,(R%NSMAX-KM+2)/2 + POA1(JF,IA+1+(J-1)*2,KMLOC) = ZOUT(JF+(J-1)*IOUT_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IOUT_STRIDES0) + ENDDO + ELSEIF (MOD(JF-1,2) == 0) THEN + !$ACC LOOP SEQ + DO J=1,(R_NSMAX+2)/2 + POA1(JF,IA+1+(J-1)*2,KMLOC) = ZOUT0((JF-1)/2+1+(J-1)*IOUT0_STRIDES0) + ENDDO + ENDIF ENDDO - ENDDO - -ENDIF - -ENDIF - -!$ACC END DATA + ENDDO + ! symmetric + + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) + ENDIF + CALL GSTATS(414,0) + + IF(KMLOC0 > 0) THEN + ! compute m=0 in double precision: + call CUDA_GEMM_BATCHED( & + & CUBLAS_OP_N, CUBLAS_OP_N, & + & KF_FS, (R%NSMAX+3)/2, G%NDGLU(0), & + & 1.0_JPRD, & + & ZINPS0, IIN0_STRIDES0, 0, & + & ZAS0, SIZE(ZAS0,1), 0, & + & 0.0_JPRD, & + & ZOUT0, IOUT0_STRIDES0, 0, & + & 1, STREAM=1_C_LONG) + ENDIF + + ! Get C in transpose format to get better memory access patterns later + !C=A*B => + ! C^T=B^T*A^T + DO KMLOC=1,D_NUMP + KM = D_MYMS(KMLOC) + NS(KMLOC) = (R%NSMAX-KM+3)/2 + KS(KMLOC) = G%NDGLU(KM) + AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC) + BOFFSETS(KMLOC) = SIZE(ZAS,1)*SIZE(ZAS,2)*(KMLOC-1) + COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM2(KMLOC) + ENDDO + IF(KMLOC0 > 0) THEN + NS(KMLOC0) = 0 + KS(KMLOC0) = 0 + ENDIF + CALL CUDA_GEMM_BATCHED( & + & 22, & ! unique identifier + & CUBLAS_OP_N, CUBLAS_OP_N, & + & 2*KF_FS, NS(:), KS(:), & + & 1.0_JPRBT, & + & ZINPS, IIN_STRIDES0, AOFFSETS, & + & ZAS, SIZE(ZAS,1), BOFFSETS, & + & 0.0_JPRBT, & + & ZOUT, IOUT_STRIDES0, COFFSETS, & + & D_NUMP, STREAM=1_C_LONG) + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(434,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(434,1) + ENDIF + CALL GSTATS(414,1) + + !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IS) DEFAULT(NONE) ASYNC(1) + DO KMLOC=1,D_NUMP + DO JF=1,2*KF_FS + KM = D_MYMS(KMLOC) + IS = 1+MOD(R_NTMAX-KM+1,2) + IF (KM /= 0) THEN + !$ACC LOOP SEQ + DO J=1,(R_NSMAX-KM+3)/2 + POA1(JF,IS+1+(J-1)*2,KMLOC) = ZOUT(JF+(J-1)*IOUT_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IOUT_STRIDES0) + ENDDO + ELSEIF (MOD(JF-1,2) == 0) THEN + !$ACC LOOP SEQ + DO J=1,(R_NSMAX+3)/2 + POA1(JF,IS+1+(J-1)*2,KMLOC) = ZOUT0((JF-1)/2+1+(J-1)*IOUT0_STRIDES0) + ENDDO + ENDIF + ENDDO + ENDDO + !$ACC WAIT(1) -IF (LHOOK) CALL DR_HOOK('LE_DGEMM',1,ZHOOK_HANDLE) -! ------------------------------------------------------------------ + !$ACC END DATA -END SUBROUTINE LEDIR + IF (LHOOK) CALL DR_HOOK('LE_DGEMM',1,ZHOOK_HANDLE) + ! ------------------------------------------------------------------ + END SUBROUTINE LEDIR END MODULE LEDIR_MOD diff --git a/src/trans/gpu/internal/ledirad_mod.F90 b/src/trans/gpu/internal/ledirad_mod.F90 deleted file mode 100755 index da66e318a..000000000 --- a/src/trans/gpu/internal/ledirad_mod.F90 +++ /dev/null @@ -1,206 +0,0 @@ -! (C) Copyright 1988- 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 LEDIRAD_MOD -CONTAINS -SUBROUTINE LEDIRAD(KM,KMLOC,KFC,KIFC,KDGLU,KLED2,PAIA,PSIA,POA1) - -!**** *LEDIRAD* - Direct Legendre transform. - -! Purpose. -! -------- -! Direct Legendre tranform of state variables. - -!** Interface. -! ---------- -! CALL LEDIRAD(...) - -! Explicit arguments : KM - zonal wavenumber -! -------------------- KFC - number of field to transform -! PAIA - antisymmetric part of Fourier -! fields for zonal wavenumber KM -! PSIA - symmetric part of Fourier -! fields for zonal wavenumber KM -! POA1 - spectral -! fields for zonal wavenumber KM -! PLEPO - Legendre polonomials - -! Implicit arguments : None. -! -------------------- - -! Method. -! ------- - -! Externals. MXMAOP - matrix multiply -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 88-01-28 -! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite -! for uv formulation -! Modified : 93-03-19 D. Giard - NTMAX instead of NSMAX -! Modified : 04/06/99 D.Salmond : change order of AIA and SIA -! Modified ! 16/10/12 J.Hague : DR_HOOK round calls to DGEMM: -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT ,JPRD -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -USE TPM_DIM ,ONLY : R -USE TPM_GEOMETRY ,ONLY : G -!USE TPM_TRANS -! -USE TPM_FLT -USE TPM_FIELDS -USE TPM_DISTR -USE BUTTERFLY_ALG_MOD - -IMPLICIT NONE - - -! DUMMY ARGUMENTS -INTEGER(KIND=JPIM), INTENT(IN) :: KM -INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM), INTENT(IN) :: KFC -INTEGER(KIND=JPIM), INTENT(IN) :: KIFC -INTEGER(KIND=JPIM), INTENT(IN) :: KDGLU -INTEGER(KIND=JPIM), INTENT(IN) :: KLED2 - -REAL(KIND=JPRBT), INTENT(OUT) :: PSIA(:,:), PAIA(:,:) -REAL(KIND=JPRBT), INTENT(IN) :: POA1(:,:) - -INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, J, JK,JGL,J1 -INTEGER(KIND=JPIM) :: IF,ITHRESHOLD -REAL(KIND=JPRBT) :: ZB(KDGLU,KIFC), ZCA((R%NTMAX-KM+2)/2,KIFC), ZCS((R%NTMAX-KM+3)/2,KIFC) -LOGICAL, PARAMETER :: LLDOUBLE = (JPRD == JPRBT) -CHARACTER(LEN=1) :: CLX -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ------------------------------------------------------------------ - -!* 1. PERFORM LEGENDRE TRANFORM. -! -------------------------- - -!* 1.1 PREPARATIONS. - -CLX = 'S' -IF (LLDOUBLE) CLX = 'D' - -IA = 1+MOD(R%NTMAX-KM+2,2) -IS = 1+MOD(R%NTMAX-KM+1,2) -ILA = (R%NTMAX-KM+2)/2 -ILS = (R%NTMAX-KM+3)/2 -ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) - -IF(KM == 0)THEN - ISKIP = 2 - DO JGL=ISL,R%NDGNH - DO J1=2,KFC,2 - PSIA(J1,JGL)=0.0_JPRBT - PAIA(J1,JGL)=0.0_JPRBT - ENDDO - ENDDO -ELSE - ISKIP = 1 -ENDIF - - -IF (KIFC > 0 .AND. KDGLU > 0 ) THEN - - ITHRESHOLD=S%ITHRESHOLD - -!* 1. ANTISYMMETRIC PART. - - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO J=1,ILA - ZCA(J,IF) = POA1(IA+(J-1)*2,JK) - ENDDO - ENDDO - - IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) - IF(LLDOUBLE)THEN - CALL DGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRBT,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZCA,ILA,0._JPRBT,ZB,KDGLU) - ELSE - CALL SGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRBT,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZCA,ILA,0._JPRBT,ZB,KDGLU) - END IF - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) - - ELSE - - CALL MULT_BUTM('N',S%FA(KMLOC)%YBUT_STRUCT_A,KIFC,ZCA,ZB) - - ENDIF - - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO J=1,KDGLU - PAIA(JK,ISL+J-1) = ZB(J,IF)*F%RW(ISL+J-1) - ENDDO - ENDDO - - -!* 1.3 SYMMETRIC PART. - - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO J=1,ILS - ZCS(J,IF) = POA1(IS+(J-1)*2,JK) - ENDDO - ENDDO - - - IF(ILS <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN - - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) - IF(LLDOUBLE)THEN - CALL DGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRBT,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZCS,ILS,0._JPRBT,ZB,KDGLU) - ELSE - CALL SGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRBT,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZCS,ILS,0._JPRBT,ZB,KDGLU) - - END IF - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) - - ELSE - - CALL MULT_BUTM('N',S%FA(KMLOC)%YBUT_STRUCT_S,KIFC,ZCS,ZB) - - ENDIF - - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO J=1,KDGLU - PSIA(JK,ISL+J-1) = ZB(J,IF)*F%RW(ISL+J-1) - ENDDO - ENDDO - -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE LEDIRAD -END MODULE LEDIRAD_MOD diff --git a/src/trans/gpu/internal/leinv_mod.F90 b/src/trans/gpu/internal/leinv_mod.F90 index 1c9ae9c0b..e893732b2 100755 --- a/src/trans/gpu/internal/leinv_mod.F90 +++ b/src/trans/gpu/internal/leinv_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,293 +10,307 @@ ! MODULE LEINV_MOD -CONTAINS -SUBROUTINE LEINV(KFC,KF_OUT_LT,PIA,PAOA1,PSOA1) - -!**** *LEINV* - Inverse Legendre transform. - -! Purpose. -! -------- -! Inverse Legendre tranform of all variables(kernel). - -!** Interface. -! ---------- -! CALL LEINV(...) + USE PARKIND_ECTRANS ,ONLY : JPIM + IMPLICIT NONE -! Explicit arguments : KM - zonal wavenumber (input-c) -! -------------------- KFC - number of fields to tranform (input-c) -! PIA - spectral fields -! for zonal wavenumber KM (input) -! PAOA1 - antisymmetric part of Fourier -! fields for zonal wavenumber KM (output) -! PSOA1 - symmetric part of Fourier -! fields for zonal wavenumber KM (output) + PRIVATE + PUBLIC :: LEINV_STRIDES, LEINV -! Implicit arguments : None. -! -------------------- + INTEGER(KIND=JPIM) :: A = 8 !Alignment -! Method. use butterfly or dgemm -! ------- - -! Externals. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Nils Wedi + Mats Hamrud + George Modzynski -! -! Modifications. -! -------------- -! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: -! F. Vana 05-Mar-2015 Support for single precision -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK -USE TPM_DIM ,ONLY : R, R_NDGNH,R_NSMAX -USE TPM_GEOMETRY ,ONLY : G, G_NDGLU -USE TPM_FIELDS ,ONLY : F, ZIA, & - & ZAA,ZAS,LDZAA,LDZAS,TDZAA,TDZAS,& - & IZBS,ILDZBA,ILDZBS,ITDZBA,ITDZBS,& - & IZCS,IZCST,ILDZCA,ILDZCS,ITDZCA,ITDZCS,& - & TDZAS, IF_FS_INV, ZAMAX, ZSMAX -USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS -USE TPM_GEN, ONLY: NOUT -USE TPM_FLT -USE BUTTERFLY_ALG_MOD -USE CUDA_GEMM_BATCHED_MOD -USE, INTRINSIC :: ISO_C_BINDING -USE IEEE_ARITHMETIC - -IMPLICIT NONE - - -! DUMMY ARGUMENTS -INTEGER(KIND=JPIM) :: KM -INTEGER(KIND=JPIM) :: KMLOC -INTEGER(KIND=JPIM), INTENT(IN) :: KFC -INTEGER(KIND=JPIM) :: KIFC -INTEGER(KIND=JPIM) :: KDGLU -INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT -REAL(KIND=JPRB), INTENT(IN) :: PIA(:,:,:) -REAL(KIND=JPRBT), INTENT(OUT) :: PSOA1(:,:,:) -REAL(KIND=JPRBT), INTENT(OUT) :: PAOA1(:,:,:) - -! LOCAL -INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, J1, IF, JGL,JK, J,JI, IRET -INTEGER(KIND=JPIM) :: ITHRESHOLD -REAL(KIND=JPRBT), ALLOCATABLE :: ZZBS(:,:,:), ZZCSTS(:,:,:) -REAL(KIND=JPRBT), ALLOCATABLE :: ZZBA(:,:,:), ZZCSTA(:,:,:) - -INTEGER(KIND=JPIM) :: ISTAT - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - - -!* 1.1 PREPARATIONS. -IF (LHOOK) CALL DR_HOOK('LE_DGEMM',0,ZHOOK_HANDLE) -! ------------------------------------------------------------------ - -!* 1. PERFORM LEGENDRE TRANFORM. -! -------------------------- - -!* 1.1 PREPARATIONS. - -ALLOCATE(ZZBA(ITDZBA,ILDZBA,D_NUMP)) -ALLOCATE(ZZCSTA(ITDZCA,ILDZCA,D_NUMP)) -ALLOCATE(ZZBS(ITDZBS,ILDZBS,D_NUMP)) -ALLOCATE(ZZCSTS(ITDZCS,ILDZCS,D_NUMP)) -!$ACC DATA CREATE(ZZBA,ZZCSTA,ZZBS,ZZCSTS) - -!$ACC DATA COPYIN (S,S%ITHRESHOLD,S%LUSEFLT) & -!$ACC& COPYIN (D,D_MYMS,R,G,G_NDGLU,D_NUMP,R_NDGNH,R_NSMAX) & -!$ACC& PRESENT (ZAA,ZAS) & -!$ACC& PRESENT (ZZBA,ZZBS,ZZCSTA,ZZCSTS) & -!$ACC& PRESENT (PIA) & -!$ACC& PRESENT (PSOA1,PAOA1,IZBS) - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO JGL=1,R_NDGNH - DO J1=2,KFC,2 - - KM = D_MYMS(KMLOC) - IF(KM == 0)THEN - PSOA1(J1,JGL,KMLOC) = 0.0_JPRBT - PAOA1(J1,JGL,KMLOC) = 0.0_JPRBT - END IF +CONTAINS + SUBROUTINE LEINV_STRIDES(KF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& + IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT, JPRD + USE TPM_DIM ,ONLY : R + USE TPM_DISTR, ONLY: D,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2 + + IMPLICIT NONE + + INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG + + INTEGER(KIND=JPIM), OPTIONAL :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM), OPTIONAL :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM), OPTIONAL :: IOUT0_STRIDES0, IOUT0_SIZE + INTEGER(KIND=JPIM), OPTIONAL :: IIN0_STRIDES0, IIN0_SIZE + + + IF (PRESENT(IOUT_STRIDES0)) & + IOUT0_STRIDES0 = ALIGN(KF_LEG,A) + IF (PRESENT(IOUT0_SIZE)) & + IOUT0_SIZE = IOUT0_STRIDES0 * ALIGN(R%NDGNH,A) + IF (PRESENT(IIN_STRIDES0)) & + IIN_STRIDES0 = ALIGN(2*KF_LEG,A) + IF (PRESENT(IIN_SIZE)) & + IIN_SIZE = IIN_STRIDES0*D_OFFSETS_GEMM2(D%NUMP+1) + IF (PRESENT(IOUT0_STRIDES0)) & + IOUT_STRIDES0 = ALIGN(2*KF_LEG,A) + IF (PRESENT(IOUT_SIZE)) & + IOUT_SIZE = IOUT_STRIDES0*D_OFFSETS_GEMM1(D%NUMP+1) + IF (PRESENT(IIN0_STRIDES0)) & + IIN0_STRIDES0 = ALIGN(KF_LEG,A) + IF (PRESENT(IIN0_SIZE)) & + IIN0_SIZE = IIN0_STRIDES0 * ALIGN(MAX((R%NTMAX+2)/2,(R%NTMAX+3)/2),A) + END SUBROUTINE + + SUBROUTINE LEINV(PIA,ZINP,ZINP0,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,KF_LEG) + !**** *LEINV* - Inverse Legendre transform. + + ! Purpose. + ! -------- + ! Inverse Legendre tranform of all variables(kernel). + + !** Interface. + ! ---------- + ! CALL LEINV(...) + + ! Explicit arguments : KM - zonal wavenumber (input-c) + ! -------------------- KFC - number of fields to tranform (input-c) + ! PIA - spectral fields + ! for zonal wavenumber KM (input) + + ! Implicit arguments : None. + ! -------------------- + + ! Method. + ! ------- + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! Nils Wedi + Mats Hamrud + George Modzynski + ! + ! Modifications. + ! -------------- + ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: + ! F. Vana 05-Mar-2015 Support for single precision + ! ------------------------------------------------------------------ + + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE PARKIND_ECTRANS ,ONLY : JPIM,JPRB, JPRBT, JPRD + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE TPM_DIM ,ONLY : R, R_NDGNH,R_NSMAX, R_NDGL + USE TPM_GEOMETRY ,ONLY : G, G_NDGLU + USE TPM_FIELDS ,ONLY : ZAA,ZAS,ZAA0,ZAS0,KMLOC0 + USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS,MYPROC,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2 + USE CUDA_GEMM_BATCHED_MOD + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + IMPLICIT NONE + + REAL(KIND=JPRB), INTENT(IN) :: PIA(:,:,:) + INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG + REAL(KIND=JPRBT), INTENT(OUT) :: ZINP(:), ZOUTS(:), ZOUTA(:) + REAL(KIND=JPRD), INTENT(OUT) :: ZINP0(:), ZOUTS0(:), ZOUTA0(:) + + ! LOCAL + INTEGER(KIND=JPIM) :: KS(D_NUMP), NS(D_NUMP), AOFFSETS(D_NUMP), BOFFSETS(D_NUMP), COFFSETS(D_NUMP) + INTEGER(KIND=JPIM) :: KM, KMLOC, IA, IS, ISL, J1, JGL, JK, J + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM) :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE + INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + + !* 1.1 PREPARATIONS. + IF (LHOOK) CALL DR_HOOK('LE_DGEMM',0,ZHOOK_HANDLE) + + ! ------------------------------------------------------------------ + + !* 1. PERFORM LEGENDRE TRANFORM. + ! -------------------------- + + !* 1.1 PREPARATIONS. + + CALL LEINV_STRIDES(KF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& + IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) + + + !$ACC DATA PRESENT(D,D_MYMS,G,G_NDGLU,R) & + !$ACC& PRESENT(ZINP,ZOUTS,ZOUTA,ZINP0,ZOUTS0,ZOUTA0) & + !$ACC& PRESENT(ZAA,ZAS,PIA) & + !$ACC& PRESENT(D_MYMS,G_NDGLU,D_OFFSETS_GEMM2) + + IF (KMLOC0 > 0) THEN + print*,'computing m=0 in double precision' + ENDIF + + ! READ 2:NSMAX+3 + + !IF KM=0 and NSMAX is 6: + ! IA=1 + ! DO=1,6/2+1 ... 1..4 + ! PIA_2=1+1+(J-1)*2 ...2+(0..3)*2 .... 2,4,6,8 + !IF KM=0 and NSMAX is 7: + ! IA=2 + ! DO=1,7/2+1 ... 1..4 + ! PIA_2=2+1+(1..4-1)*2 ...3+(0..3)*2 .... 3,5,7,9 + + !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IA,J) DEFAULT(NONE) ASYNC(1) + DO KMLOC=1,D_NUMP + DO JK=1,2*KF_LEG + KM = D_MYMS(KMLOC) + IA = 1+MOD(R_NSMAX-KM+2,2) + IF(KM /= 0)THEN + !$ACC LOOP SEQ + DO J=1,(R_NSMAX-KM+2)/2 + ZINP(JK+(J-1)*IIN_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IIN_STRIDES0)=PIA(JK,IA+1+(J-1)*2,KMLOC) + ENDDO + ELSEIF (MOD((JK-1),2) .EQ. 0) THEN + ! every other field is sufficient because Im(KM=0) == 0 + !$ACC LOOP SEQ + DO J=1,(R_NSMAX+2)/2 + ZINP0((JK-1)/2+1+(J-1)*IIN0_STRIDES0) = PIA(JK,IA+1+(J-1)*2,KMLOC) + ENDDO + ENDIF ENDDO - ENDDO - !end loop over wavenumber -END DO - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,ISKIP,ILA,ILS,IA) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,(R_NSMAX+2)/2 - DO JK=1,KFC - - KM = D_MYMS(KMLOC) - IF (KM == 0) THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - ILA = (R_NSMAX-KM+2)/2 - IF (J .LE. ILA) THEN - IA = 1+MOD(R_NSMAX-KM+2,2) -!! IZBA((JK-1)/ISKIP+1,J,KMLOC)=PIA(JK,IA+1+(J-1)*2,KMLOC)*RRPELTMINV/ZAMAX((JK-1)/ISKIP+1,KMLOC) - IZBS((JK-1)/ISKIP+1+(J-1+(KMLOC-1)*TDZAA)*IF_FS_INV)=PIA(JK,IA+1+(J-1)*2,KMLOC) - ENDIF - ENDIF ENDDO - ENDDO -ENDDO - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,ISKIP,ILA,ILS,IA) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,(R_NSMAX+2)/2 - DO JK=1,KFC - KM = D_MYMS(KMLOC) - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - ILA = (R_NSMAX-KM+2)/2 - IF (J .LE. ILA) THEN - IA = 1+MOD(R_NSMAX-KM+2,2) - ZZBA((JK-1)/ISKIP+1,J,KMLOC)=PIA(JK,IA+1+(J-1)*2,KMLOC) - ENDIF - ENDIF + + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) + ENDIF + CALL GSTATS(424,0) + + IF (KMLOC0 > 0) THEN + ! compute m=0 in double precision: + CALL CUDA_GEMM_BATCHED( & + & CUBLAS_OP_N, CUBLAS_OP_T, & + & KF_LEG, G%NDGLU(0), (R%NSMAX+2)/2, & + & 1.0_JPRD, & + & ZINP0, IIN0_STRIDES0, 0, & + & ZAA0, SIZE(ZAA0,1), 0, & + & 0.0_JPRD, & + & ZOUTA0, IOUT0_STRIDES0, 0, & + & 1, STREAM=1_C_LONG) + ENDIF + + DO KMLOC=1,D_NUMP + KM = D_MYMS(KMLOC) + KS(KMLOC) = (R%NSMAX-KM+2)/2 + NS(KMLOC) = G%NDGLU(KM) + AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM2(KMLOC) + BOFFSETS(KMLOC) = SIZE(ZAA,1)*SIZE(ZAA,2)*(KMLOC-1) + COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM1(KMLOC) ENDDO - ENDDO -ENDDO - -ITHRESHOLD=S%ITHRESHOLD - -! operate on full arrays, where non-relavent entries have been set to zero -! call CUDA_DGEMM_BATCHED('N','N',LDZAA,TDZBA,TDZAA,1.0_JPRB,ZAA,LDZAA,TDZAA,ZBA,LDZBA,TDZBA,0._JPRB,ZCA,LDZCA,TDZCA,D_NUMP) -! Get C in transpose format to get better memory access patterns later -!C=A*B => -! C^T=B^T*A^T - - -! OVERLOADED FOR SINGLE AND DOUBLE PRECISION -!$ACC HOST_DATA USE_DEVICE(ZAA,ZZBA,ZZCSTA) -CALL CUDA_GEMM_BATCHED( & - & 'N', 'T', & - & ITDZCA, ILDZCA, ILDZBA, & - & 1.0_JPRBT, & - & ZZBA, ITDZBA, ILDZBA,& - & ZAA, LDZAA, TDZAA, & - & 0._JPRBT, & - & ZZCSTA, ITDZCA, ILDZCA, & - & D_NUMP) -!$ACC END HOST_DATA - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,KDGLU,ISKIP,ISL) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO JI=1,R_NDGNH - DO JK=1,KFC - KM = D_MYMS(KMLOC) - KDGLU = MIN(R_NDGNH,G_NDGLU(KM)) - IF (JI .LE. KDGLU) then - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - END IF - - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - PAOA1(JK,ISL+JI-1,KMLOC) = ZZCSTA((JK-1)/ISKIP+1,JI,KMLOC) - END IF - END IF + IF(KMLOC0 > 0) THEN + NS(KMLOC0) = 0 + KS(KMLOC0) = 0 + ENDIF + CALL CUDA_GEMM_BATCHED( & + & 11, & ! unique identifier + & CUBLAS_OP_N, CUBLAS_OP_T, & + & 2*KF_LEG, NS(:), KS(:), & + & 1.0_JPRBT, & + & ZINP, IIN_STRIDES0, AOFFSETS, & + & ZAA, SIZE(ZAA,1), BOFFSETS, & + & 0.0_JPRBT, & + & ZOUTA, IOUT_STRIDES0, COFFSETS, & + & D_NUMP, STREAM=1_C_LONG) + + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(444,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(444,1) + ENDIF + CALL GSTATS(424,1) + + ! 2. +++++++++++++ symmetric + !IF KM=0 and NSMAX is 6: + ! IS=2 + ! DO=1,4 + ! PIA_2=2+1+(0..3)*2 ... 3+(0..3)*2 ... 3,5,7,9 + !IF KM=0 and NSMAX is 7: + ! IS=1 + ! DO=1,5 + ! PIA_2=1+1+(1..5-1)*2 ...2+(0..4)*2 .... 2,4,6,8,10 + + !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IS,J) DEFAULT(NONE) ASYNC(1) + DO KMLOC=1,D_NUMP + DO JK=1,2*KF_LEG + KM = D_MYMS(KMLOC) + IS = 1+MOD(R_NSMAX-KM+1,2) + IF(KM /= 0) THEN + !$ACC LOOP SEQ + DO J=1,(R_NSMAX-KM+3)/2 + ZINP(JK+(J-1)*IIN_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IIN_STRIDES0)=PIA(JK,IS+1+(J-1)*2,KMLOC) + ENDDO + ELSEIF (MOD((JK-1),2) == 0) THEN + !$ACC LOOP SEQ + DO J=1,(R_NSMAX+3)/2 + ZINP0((JK-1)/2+1+(J-1)*IIN0_STRIDES0) = PIA(JK,IS+1+(J-1)*2,KMLOC) + ENDDO + ENDIF ENDDO - ENDDO -END DO - -! 2. +++++++++++++ symmetric - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,ISKIP,ILS,IS) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO J=1,(R_NSMAX+3)/2 - DO JK=1,KFC - KM = D_MYMS(KMLOC) - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - ENDIF - - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - ILS = (R_NSMAX-KM+3)/2 - IF (J .LE. ILS) THEN - IS = 1+MOD(R_NSMAX-KM+1,2) - ZZBS((JK-1)/ISKIP+1,J,KMLOC)=PIA(JK,IS+1+(J-1)*2,KMLOC) - END IF - END IF ENDDO - ENDDO -ENDDO - -!C=A*B => -! C^T=B^T*A^T - -!$ACC HOST_DATA USE_DEVICE(ZAS,ZZBS,ZZCSTS) -CALL CUDA_GEMM_BATCHED( & - & 'N', 'T', & - & ITDZCS, ILDZCS, ILDZBS, & - & 1.0_JPRBT, & - & ZZBS, ITDZBS, ILDZBS, & - & ZAS, LDZAS, TDZAS, & - & 0._JPRBT, & - & ZZCSTS, ITDZCS, ILDZCS, & - & D_NUMP) -!$ACC END HOST_DATA - - -!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,KDGLU,ISKIP,ISL) DEFAULT(NONE) -DO KMLOC=1,D_NUMP - DO JI=1,R_NDGNH - DO JK=1,KFC - KM = D_MYMS(KMLOC) - KDGLU = MIN(R_NDGNH,G_NDGLU(KM)) - IF (JI .LE. KDGLU) then - IF(KM == 0)THEN - ISKIP = 2 - ELSE - ISKIP = 1 - END IF - - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) - IF (MOD((JK-1),ISKIP) .EQ. 0) THEN - !PSOA1(JK,ISL+JI-1,KMLOC) = IZCST((JK-1)/ISKIP+1+(JI-1+(KMLOC-1)*R_NDGNH)*IF_FS_INV) - PSOA1(JK,ISL+JI-1,KMLOC) = ZZCSTS((JK-1)/ISKIP+1,JI,KMLOC) - END IF - END IF - ENDDO - ENDDO -END DO - -!$ACC END DATA -!$ACC END DATA -DEALLOCATE(ZZBS) -DEALLOCATE(ZZBA) -DEALLOCATE(ZZCSTS) -DEALLOCATE(ZZCSTA) - -IF (LHOOK) CALL DR_HOOK('LE_DGEMM',1,ZHOOK_HANDLE) -! ------------------------------------------------------------------ - -END SUBROUTINE LEINV + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) + ENDIF + CALL GSTATS(424,0) + + IF (KMLOC0 > 0) THEN + CALL CUDA_GEMM_BATCHED( & + & CUBLAS_OP_N, CUBLAS_OP_T, & + & KF_LEG, G%NDGLU(0), (R%NSMAX+3)/2, & + & 1.0_JPRD, & + & ZINP0, IIN0_STRIDES0, 0, & + & ZAS0, SIZE(ZAS0,1), 0, & + & 0.0_JPRD, & + & ZOUTS0, IOUT0_STRIDES0, 0, & + & 1, STREAM=1_C_LONG) + ENDIF + + DO KMLOC=1,D_NUMP + KM = D_MYMS(KMLOC) + KS(KMLOC) = (R%NSMAX-KM+3)/2 + NS(KMLOC) = G%NDGLU(KM) + AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM2(KMLOC) + BOFFSETS(KMLOC) = SIZE(ZAS,1)*SIZE(ZAS,2)*(KMLOC-1) + COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM1(KMLOC) + ENDDO + IF(KMLOC0 > 0) THEN + NS(KMLOC0) = 0 + KS(KMLOC0) = 0 + ENDIF + CALL CUDA_GEMM_BATCHED( & + & 12, & ! unique identifier + & CUBLAS_OP_N, CUBLAS_OP_T, & + & 2*KF_LEG, NS(:), KS(:), & + & 1.0_JPRBT, & + & ZINP, IIN_STRIDES0, AOFFSETS, & + & ZAS, SIZE(ZAS,1), BOFFSETS, & + & 0.0_JPRBT, & + & ZOUTS, IOUT_STRIDES0, COFFSETS, & + & D_NUMP, STREAM=1_C_LONG) + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(444,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(444,1) + ENDIF + CALL GSTATS(424,1) + + !$ACC WAIT(1) + + !$ACC END DATA + + IF (LHOOK) CALL DR_HOOK('LE_DGEMM',1,ZHOOK_HANDLE) + ! ------------------------------------------------------------------ + END SUBROUTINE LEINV END MODULE LEINV_MOD diff --git a/src/trans/gpu/internal/leinvad_mod.F90 b/src/trans/gpu/internal/leinvad_mod.F90 deleted file mode 100755 index b1695ff55..000000000 --- a/src/trans/gpu/internal/leinvad_mod.F90 +++ /dev/null @@ -1,196 +0,0 @@ -! (C) Copyright 2001- 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 LEINVAD_MOD -CONTAINS -SUBROUTINE LEINVAD(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KDGLU,PIA,PAOA1,PSOA1) - -!**** *LEINVAD* - Inverse Legendre transform. - -! Purpose. -! -------- -! Inverse Legendre tranform of all variables(kernel). - -!** Interface. -! ---------- -! CALL LEINVAD(...) - -! Explicit arguments : KM - zonal wavenumber (input-c) -! -------------------- KFC - number of fields to tranform (input-c) -! PIA - spectral fields -! for zonal wavenumber KM (input) -! PAOA1 - antisymmetric part of Fourier -! fields for zonal wavenumber KM (output) -! PSOA1 - symmetric part of Fourier -! fields for zonal wavenumber KM (output) - -! Implicit arguments : None. -! -------------------- - -! Method. -! ------- - -! Externals. MXMAOP - calls SGEMVX (matrix multiply) -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From LEINVAD in IFS CY22R1 -! Modified ! 16/10/12 J.Hague : DR_HOOK round calls to DGEMM: -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT, JPRD -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -USE TPM_DIM ,ONLY : R -USE TPM_GEOMETRY ,ONLY : G -USE TPM_FIELDS ,ONLY : F -!USE TPM_TRANS -USE TPM_DISTR ,ONLY : D -! -USE TPM_FLT -USE BUTTERFLY_ALG_MOD - -IMPLICIT NONE - -INTEGER(KIND=JPIM), INTENT(IN) :: KM -INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM), INTENT(IN) :: KFC -INTEGER(KIND=JPIM), INTENT(IN) :: KIFC -INTEGER(KIND=JPIM), INTENT(IN) :: KDGLU -INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT -REAL(KIND=JPRB), INTENT(OUT) :: PIA(:,:) -REAL(KIND=JPRBT), INTENT(INOUT) :: PSOA1(:,:) -REAL(KIND=JPRBT), INTENT(INOUT) :: PAOA1(:,:) - -! LOCAL VARIABLES -INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, IOAD1, JK,JI -INTEGER(KIND=JPIM) :: IF,ITHRESHOLD -REAL(KIND=JPRBT) :: ZBA((R%NSMAX-KM+2)/2,KIFC), ZBS((R%NSMAX-KM+3)/2,KIFC), ZC(KDGLU,KIFC) -LOGICAL, PARAMETER :: LLDOUBLE = (JPRD == JPRBT) -CHARACTER(LEN=1) :: CLX -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ------------------------------------------------------------------ - -!* 1. PERFORM LEGENDRE TRANFORM. -! -------------------------- - -!* 1.1 PREPARATIONS. - -CLX = 'S' -IF (LLDOUBLE) CLX = 'D' - -IA = 1+MOD(R%NSMAX-KM+2,2) -IS = 1+MOD(R%NSMAX-KM+1,2) -ILA = (R%NSMAX-KM+2)/2 -ILS = (R%NSMAX-KM+3)/2 -ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) -IOAD1 = 2*KF_OUT_LT - -IF(KM == 0)THEN - ISKIP = 2 -ELSE - ISKIP = 1 -ENDIF - -IF( KDGLU > 0 ) THEN - - ITHRESHOLD=S%ITHRESHOLD - - -! 1. +++++++++++++ anti-symmetric - - ! we need the transpose of C - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO JI=1,KDGLU - ZC(JI,IF) = PAOA1(JK,ISL+JI-1) - ENDDO - ENDDO - - IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) - IF(LLDOUBLE)THEN - CALL DGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRBT,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZC,KDGLU,0._JPRBT,ZBA,ILA) - ELSE - CALL SGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRBT,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZC,KDGLU,0._JPRBT,ZBA,ILA) - END IF - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) - - ELSE - - CALL MULT_BUTM('T',S%FA(KMLOC)%YBUT_STRUCT_A,KIFC,ZC,ZBA) - - ENDIF - - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO JI=1,ILA - PIA(IA+1+(JI-1)*2,JK) = ZBA(JI,IF) - ENDDO - ENDDO - -! 2. +++++++++++++ symmetric - - ! we need the transpose of C - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO JI=1,KDGLU - ZC(JI,IF) = PSOA1(JK,ISL+JI-1) - ENDDO - ENDDO - - IF(ILS <= ITHRESHOLD .OR. .NOT.S%LUSEFLT ) THEN - - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) - IF(LLDOUBLE)THEN - CALL DGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRBT,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZC,KDGLU,0._JPRBT,ZBS,ILS) - ELSE - CALL SGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRBT,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZC,KDGLU,0._JPRBT,ZBS,ILS) - END IF - IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) - - ELSE - - CALL MULT_BUTM('T',S%FA(KMLOC)%YBUT_STRUCT_S,KIFC,ZC,ZBS) - - ENDIF - - IF=0 - DO JK=1,KFC,ISKIP - IF=IF+1 - DO JI=1,ILS - PIA(IS+1+(JI-1)*2,JK) = ZBS(JI,IF) - ENDDO - ENDDO - - -ENDIF -! -! ------------------------------------------------------------------ - - -END SUBROUTINE LEINVAD -END MODULE LEINVAD_MOD diff --git a/src/trans/gpu/internal/ltdir_ctl_mod.F90 b/src/trans/gpu/internal/ltdir_ctl_mod.F90 deleted file mode 100755 index 367aba00f..000000000 --- a/src/trans/gpu/internal/ltdir_ctl_mod.F90 +++ /dev/null @@ -1,106 +0,0 @@ -! (C) Copyright 2000- 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 LTDIR_CTL_MOD - CONTAINS - SUBROUTINE LTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & - & PSPVOR,PSPDIV,PSPSCALAR, & - & PSPSC3A,PSPSC3B,PSPSC2, & - & KFLDPTRUV,KFLDPTRSC) - - !**** *LTDIR_CTL* - Control routine for direct Legendre transform - - ! Purpose. - ! -------- - ! Direct Legendre transform - - !** Interface. - ! ---------- - ! CALL LTDIR_CTL(...) - - ! Explicit arguments : - ! -------------------- - ! KF_FS - number of fields in Fourier space - ! KF_UV - local number of spectral u-v fields - ! KF_SCALARS - local number of scalar spectral fields - ! PSPVOR(:,:) - spectral vorticity (output) - ! PSPDIV(:,:) - spectral divergence (output) - ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) - ! KFLDPTRUV(:) - field pointer for vorticity and divergence (input) - ! KFLDPTRSC(:) - field pointer for scalarvalued fields (input) - - ! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB - - USE TPM_GEN, only: nout - USE TPM_DIM ,ONLY : R - USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN - USE TPM_DISTR ,ONLY : D - USE TPM_GEOMETRY ,ONLY : G - USE TPM_FIELDS ,ONLY : F - - - USE LTDIR_MOD ,ONLY : LTDIR - USE TRLTOM_MOD ,ONLY : TRLTOM, TRLTOM_CUDAAWARE - - USE TPM_FIELDS ,ONLY : ZSIA,ZAIA,ZOA1,ZEPSNM - - IMPLICIT NONE - - INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - - INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2 - - !$ACC DATA PRESENT(FOUBUF_IN) CREATE(FOUBUF) - - ! Transposition from Fourier space distribution to spectral space distribution - ! requires currently both on the host !!! - - IBLEN = D%NLENGT0B*2*KF_FS - CALL GSTATS(153,0) -#ifdef USE_CUDA_AWARE_MPI_FT - WRITE(NOUT,*) 'ltdir_ctl:TRLTOM_CUDAAWARE' - CALL TRLTOM_CUDAAWARE(FOUBUF_IN,FOUBUF,2*KF_FS) -#else - CALL TRLTOM(FOUBUF_IN,FOUBUF,2*KF_FS) - !$ACC UPDATE DEVICE(FOUBUF) -#endif - CALL GSTATS(153,1) - - ! Direct Legendre transform - - CALL GSTATS(103,0) - ILED2 = 2*KF_FS - CALL GSTATS(1645,0) - IF(KF_FS>0) THEN - - CALL LTDIR(KF_FS,KF_UV,KF_SCALARS,ILED2, & - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC) - - ENDIF - !$ACC END DATA - CALL GSTATS(1645,1) - - CALL GSTATS(103,1) - - ! ----------------------------------------------------------------- - - END SUBROUTINE LTDIR_CTL - END MODULE LTDIR_CTL_MOD diff --git a/src/trans/gpu/internal/ltdir_ctlad_mod.F90 b/src/trans/gpu/internal/ltdir_ctlad_mod.F90 deleted file mode 100755 index dcf8a5f54..000000000 --- a/src/trans/gpu/internal/ltdir_ctlad_mod.F90 +++ /dev/null @@ -1,109 +0,0 @@ -! (C) Copyright 2000- 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 LTDIR_CTLAD_MOD -CONTAINS -SUBROUTINE LTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & - & PSPVOR,PSPDIV,PSPSCALAR, & - & PSPSC3A,PSPSC3B,PSPSC2, & - & KFLDPTRUV,KFLDPTRSC) - -!**** *LTDIR_CTLAD* - Control routine for direct Legendre transform - -! Purpose. -! -------- -! Direct Legendre transform - -!** Interface. -! ---------- -! CALL LTDIR_CTLAD(...) - -! Explicit arguments : -! -------------------- -! PSPVOR(:,:) - spectral vorticity (output) -! PSPDIV(:,:) - spectral divergence (output) -! PSPSCALAR(:,:) - spectral scalarvalued fields (output) - -! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -USE TPM_GEN ,ONLY : LALLOPERM -!USE TPM_DIM -USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN -USE TPM_DISTR ,ONLY : D - -USE LTDIRAD_MOD ,ONLY : LTDIRAD -USE TRMTOL_MOD ,ONLY : TRMTOL -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - -INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2 - -! ------------------------------------------------------------------ - -! Transposition from Fourier space distribution to spectral space distribution - -CALL GSTATS(105,0) -IBLEN = D%NLENGT0B*2*KF_FS -IF (ALLOCATED(FOUBUF_IN)) THEN - IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN - DEALLOCATE(FOUBUF_IN) - ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) - ENDIF -ELSE - ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) -ENDIF -IF (ALLOCATED(FOUBUF)) THEN - IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN - DEALLOCATE(FOUBUF) - ALLOCATE(FOUBUF(MAX(1,IBLEN))) - ENDIF -ELSE - ALLOCATE(FOUBUF(MAX(1,IBLEN))) -ENDIF - -! Direct Legendre transform - -ILED2 = 2*KF_FS -CALL GSTATS(1646,0) -IF(KF_FS > 0) THEN -!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) - DO JM=1,D%NUMP - IM = D%MYMS(JM) - CALL LTDIRAD(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC) - ENDDO -!$OMP END PARALLEL DO -ENDIF -CALL GSTATS(1646,1) - -CALL GSTATS(105,1) - -CALL GSTATS(181,0) -CALL TRMTOL(FOUBUF,FOUBUF_IN,2*KF_FS) -CALL GSTATS(181,1) -IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) -! ------------------------------------------------------------------ - -END SUBROUTINE LTDIR_CTLAD -END MODULE LTDIR_CTLAD_MOD diff --git a/src/trans/gpu/internal/ltdir_mod.F90 b/src/trans/gpu/internal/ltdir_mod.F90 index 9cae24ddd..6058a41e5 100755 --- a/src/trans/gpu/internal/ltdir_mod.F90 +++ b/src/trans/gpu/internal/ltdir_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1987- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,204 +10,274 @@ ! MODULE LTDIR_MOD - CONTAINS - SUBROUTINE LTDIR(KF_FS,KF_UV,KF_SCALARS,KLED2,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2, & - & KFLDPTRUV,KFLDPTRSC) - - - USE PARKIND1 ,ONLY : JPIM ,JPRB - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE TPM_DIM ,ONLY : R - USE TPM_DISTR ,ONLY : D - USE TPM_GEOMETRY - - USE PREPSNM_MOD ,ONLY : PREPSNM - USE PRFI2B_MOD ,ONLY : PRFI2B - USE LDFOU2_MOD ,ONLY : LDFOU2 - USE LEDIR_MOD ,ONLY : LEDIR - USE UVTVD_MOD - USE UPDSP_MOD ,ONLY : UPDSP - - USE TPM_FIELDS ,ONLY : ZAIA,ZOA1,ZOA2,ZEPSNM - - !**** *LTDIR* - Control of Direct Legendre transform step - - ! Purpose. - ! -------- - ! Tranform from Fourier space to spectral space, compute - ! vorticity and divergence. - - !** Interface. - ! ---------- - ! *CALL* *LTDIR(...)* - - ! Explicit arguments : - ! -------------------- KM - zonal wavenumber - ! KMLOC - local zonal wavenumber - - ! Implicit arguments : None - ! -------------------- - - ! Method. - ! ------- - - ! Externals. - ! ---------- - ! PREPSNM - prepare REPSNM for wavenumber KM - ! PRFI2 - prepares the Fourier work arrays for model variables. - ! LDFOU2 - computations in Fourier space - ! LEDIR - direct Legendre transform - ! UVTVD - - ! UPDSP - updating of spectral arrays (fields) - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! Mats Hamrud and Philippe Courtier *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 87-11-24 - ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite - ! for uv formulation - ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies - ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer - ! Modified 94-04-06 R. El khatib Full-POS implementation - ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div - ! instead of u,v->vor,div - ! MPP Group : 95-10-01 Support for Distributed Memory version - ! K. YESSAD (AUGUST 1996): - ! - Legendre transforms for transmission coefficients. - ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA - ! R. El Khatib 12-Jul-2012 LDSPC2 replaced by UVTVD - ! ------------------------------------------------------------------ - + USE ALLOCATOR_MOD IMPLICIT NONE - - INTERFACE - SUBROUTINE cudaProfilerStart() BIND(C,name='cudaProfilerStart') - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT - IMPLICIT NONE - END SUBROUTINE cudaProfilerStart - END INTERFACE - - INTERFACE - SUBROUTINE cudaProfilerStop() BIND(C,name='cudaProfilerStop') - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT - IMPLICIT NONE - END SUBROUTINE cudaProfilerStop - END INTERFACE - - - - ! DUMMY INTEGER SCALARS - INTEGER(KIND=JPIM) :: KM - INTEGER(KIND=JPIM) :: KMLOC - INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 - - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - - ! LOCAL INTEGER SCALARS - INTEGER(KIND=JPIM) :: IFC, IIFC, IDGLU - INTEGER(KIND=JPIM) :: IUS, IUE, IVS, IVE, IVORS, IVORE, IDIVS, IDIVE - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - - - !call cudaProfilerStart - - ! ------------------------------------------------------------------ - IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',0,ZHOOK_HANDLE) - - ! ------------------------------------------------------------------ - - !* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM - ! -------------------------------------- - - - ! ------------------------------------------------------------------ - - !* 2. PREPARE WORK ARRAYS. - ! -------------------- - - ! serial to save memory, Nils - - ! anti-symmetric - - - CALL PRFI2B(KF_FS,ZAIA,-1) - CALL LDFOU2(KF_UV,ZAIA) - CALL LEDIR(KF_FS,KLED2,ZAIA,ZOA1,-1) - - - ! symmetric - - CALL PRFI2B(KF_FS,ZAIA,1) - CALL LDFOU2(KF_UV,ZAIA) - CALL LEDIR(KF_FS,KLED2,ZAIA,ZOA1,1) - - ! ------------------------------------------------------------------ - - !* 5. COMPUTE VORTICITY AND DIVERGENCE. - ! --------------------------------- - - IF( KF_UV > 0 ) THEN - !stop 'Error: code path not (yet) supported in GPU version' - - !!CALL PREPSNM - - IUS = 1 - IUE = 2*KF_UV - IVS = 2*KF_UV+1 - IVE = 4*KF_UV - IVORS = 1 - IVORE = 2*KF_UV - IDIVS = 2*KF_UV+1 - IDIVE = 4*KF_UV - CALL UVTVD(KF_UV) - ! CALL UVTVD(KF_UV,ZEPSNM,ZOA1(IUS:IUE,:,:),ZOA1(IVS:IVE,:,:),& -! & ZOA2(IVORS:IVORE,:,:),ZOA2(IDIVS:IDIVE,:,:)) - ENDIF - ! ------------------------------------------------------------------ - - !* 6. UPDATE SPECTRAL ARRAYS. - ! ----------------------- - - !end loop over wavenumber - - !END DO - - !loop over wavenumber - !DO KMLOC=1,D%NUMP - ! KM = D%MYMS(KMLOC) - - ! this is on the host, so need to cp from device, Nils - CALL UPDSP(KF_UV,KF_SCALARS,ZOA1,ZOA2, & - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC) - - ! ------------------------------------------------------------------ - - IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',1,ZHOOK_HANDLE) - - !end loop over wavenumber - !END DO - - - !call cudaProfilerStop + + PRIVATE + PUBLIC :: PREPARE_LTDIR, LTDIR_HANDLE, LTDIR + + TYPE LTDIR_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HOUT_AND_POA + END TYPE + +CONTAINS + FUNCTION PREPARE_LTDIR(ALLOCATOR, KF_FS, KF_UV) RESULT(HLTDIR) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD + USE TPM_DISTR, ONLY: D + USE TPM_DIM, ONLY: R + USE ISO_C_BINDING + USE LEDIR_MOD + USE ALLOCATOR_MOD + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV + TYPE(LTDIR_HANDLE) :: HLTDIR + + INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE + + REAL(KIND=JPRBT) :: ZPRBT_DUMMY + REAL(KIND=JPRD) :: ZPRD_DUMMY + + CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& + IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) + + ! POA1 + IALLOC_SZ = ALIGN(2*KF_FS*(R%NTMAX+3)*D%NUMP*SIZEOF(ZPRBT_DUMMY),128) + ! POA2 + IALLOC_SZ = IALLOC_SZ + ALIGN(4*KF_UV*(R%NTMAX+3)*D%NUMP*SIZEOF(ZPRBT_DUMMY),128) + ! ZOUT + IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*SIZEOF(ZPRBT_DUMMY),128) + ! ZOUT0 + IALLOC_SZ = IALLOC_SZ+ ALIGN(IOUT0_SIZE*SIZEOF(ZPRD_DUMMY),128) + + HLTDIR%HOUT_AND_POA = RESERVE(ALLOCATOR, IALLOC_SZ) + END FUNCTION + + SUBROUTINE LTDIR(ALLOCATOR,HLTDIR,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV,KF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2, & + & KFLDPTRUV,KFLDPTRSC) + + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT, JPRD, JPRB + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + USE TPM_DIM ,ONLY : R + USE TPM_DISTR ,ONLY : D + USE TPM_GEOMETRY + + USE PREPSNM_MOD ,ONLY : PREPSNM + USE LEDIR_MOD + USE UVTVD_MOD + USE UPDSP_MOD ,ONLY : UPDSP + USE UPDSPB_MOD ,ONLY : UPDSPB + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + USE ALLOCATOR_MOD + + + !**** *LTDIR* - Control of Direct Legendre transform step + + ! Purpose. + ! -------- + ! Tranform from Fourier space to spectral space, compute + ! vorticity and divergence. + + !** Interface. + ! ---------- + ! *CALL* *LTDIR(...)* + + ! Explicit arguments : + ! -------------------- KM - zonal wavenumber + ! KMLOC - local zonal wavenumber + + ! Implicit arguments : None + ! -------------------- + + ! Method. + ! ------- + + ! Externals. + ! ---------- + ! PREPSNM - prepare REPSNM for wavenumber KM + ! PRFI2 - prepares the Fourier work arrays for model variables. + ! LEDIR - direct Legendre transform + ! UVTVD - + ! UPDSP - updating of spectral arrays (fields) + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! Mats Hamrud and Philippe Courtier *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 87-11-24 + ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite + ! for uv formulation + ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies + ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer + ! Modified 94-04-06 R. El khatib Full-POS implementation + ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div + ! instead of u,v->vor,div + ! MPP Group : 95-10-01 Support for Distributed Memory version + ! K. YESSAD (AUGUST 1996): + ! - Legendre transforms for transmission coefficients. + ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA + ! R. El Khatib 12-Jul-2012 LDSPC2 replaced by UVTVD + ! ------------------------------------------------------------------ + + IMPLICIT NONE + + ! DUMMY INTEGER SCALARS + INTEGER(KIND=JPIM) :: KM + INTEGER(KIND=JPIM) :: KMLOC + INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS + + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) + REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) + INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) + INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) + REAL(KIND=JPRBT), INTENT(IN) :: ZINPS(:), ZINPA(:) + REAL(KIND=JPRD), INTENT(IN) :: ZINPS0(:), ZINPA0(:) + + ! LOCAL INTEGER SCALARS + INTEGER(KIND=JPIM) :: IFC, IIFC, IDGLU, IFIRST + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + REAL(KIND=JPRB), POINTER :: POA1_L(:), POA1(:,:,:) + REAL(KIND=JPRB), POINTER :: POA2_L(:), POA2(:,:,:) + REAL(KIND=JPRB), POINTER :: PU(:,:,:), PV(:,:,:), PVOR(:,:,:), PDIV(:,:,:) + REAL(KIND=JPRBT), POINTER :: ZOUT(:) + REAL(KIND=JPRD), POINTER :: ZOUT0(:) + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(LTDIR_HANDLE), INTENT(IN) :: HLTDIR + INTEGER(KIND=C_SIZE_T) :: IALLOC_POS, IALLOC_SZ + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE + + + + ! ------------------------------------------------------------------ + IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',0,ZHOOK_HANDLE) + + ! ------------------------------------------------------------------ + + !* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM + ! -------------------------------------- + + + ! ------------------------------------------------------------------ + + !* 2. PREPARE WORK ARRAYS. + ! -------------------- + CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& + IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) + + IALLOC_POS = 1 + + IALLOC_SZ = ALIGN(2*KF_FS*(R%NTMAX+3)*D%NUMP*SIZEOF(POA1_L(1)),128) + CALL ASSIGN_PTR(POA1_L, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& + & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) + CALL C_F_POINTER(C_LOC(POA1_L), POA1, (/ 2*KF_FS, R%NTMAX+3, D%NUMP /)) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + IALLOC_SZ = ALIGN(4*KF_UV*(R%NTMAX+3)*D%NUMP*SIZEOF(POA2_L(1)),128) + CALL ASSIGN_PTR(POA2_L, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& + & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) + CALL C_F_POINTER(C_LOC(POA2_L), POA2, (/ 4*KF_UV, R%NTMAX+3, D%NUMP /)) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZOUT + IALLOC_SZ = ALIGN(IOUT_SIZE*SIZEOF(ZOUT(1)),128) + CALL ASSIGN_PTR(ZOUT, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& + & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZOUT0 + IALLOC_SZ = ALIGN(IOUT0_SIZE*SIZEOF(ZOUT0(1)),128) + CALL ASSIGN_PTR(ZOUT0, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& + & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! do the legendre transform + CALL LEDIR(ZINPS,ZINPA,ZINPS0,ZINPA0,ZOUT,ZOUT0,POA1,KF_FS) + + !$ACC DATA COPYOUT(PSPVOR,PSPDIV) IF(KF_UV > 0) + !$ACC DATA COPYOUT(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) + !$ACC DATA COPYOUT(PSPSC2) IF(NF_SC2 > 0) + !$ACC DATA COPYOUT(PSPSC3A) IF(NF_SC3A > 0) + !$ACC DATA COPYOUT(PSPSC3B) IF(NF_SC3B > 0) + + ! ------------------------------------------------------------------ + + !* 5. COMPUTE VORTICITY AND DIVERGENCE. + ! --------------------------------- + + IF( KF_UV > 0 ) THEN + ! U and V are in POA1 + IFIRST = 0 + PU => POA1(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV + PV => POA1(IFIRST+1:IFIRST+2*KF_UV,:,:) + ! Compute VOR and DIV ino POA2 + IFIRST = 0 + PVOR => POA2(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV + PDIV => POA2(IFIRST+1:IFIRST+2*KF_UV,:,:) + + ! Compute vorticity and divergence + CALL UVTVD(KF_UV,PU,PV,PVOR,PDIV) + + ! Write back. Note, if we have UV, the contract says we *must* have VOR/DIV + CALL UPDSPB(KF_UV,PVOR,PSPVOR,KFLDPTRUV) + CALL UPDSPB(KF_UV,PDIV,PSPDIV,KFLDPTRUV) + + ENDIF + ! ------------------------------------------------------------------ + + !* 6. UPDATE SPECTRAL ARRAYS. + ! ----------------------- + + ! this is on the host, so need to cp from device, Nils + CALL UPDSP(KF_UV,KF_SCALARS,POA1,& + & PSPSCALAR,& + & PSPSC3A,PSPSC3B,PSPSC2 , & + & KFLDPTRUV,KFLDPTRSC) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) + ENDIF + CALL GSTATS(412,0) + !$ACC END DATA + !$ACC END DATA + !$ACC END DATA + !$ACC END DATA + !$ACC END DATA + IF (LSYNC_TRANS) THEN + CALL GSTATS(432,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(432,1) + ENDIF + CALL GSTATS(412,1) + + ! ------------------------------------------------------------------ + + IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',1,ZHOOK_HANDLE) END SUBROUTINE LTDIR - END MODULE LTDIR_MOD +END MODULE LTDIR_MOD diff --git a/src/trans/gpu/internal/ltdirad_mod.F90 b/src/trans/gpu/internal/ltdirad_mod.F90 deleted file mode 100755 index 63c6b2b59..000000000 --- a/src/trans/gpu/internal/ltdirad_mod.F90 +++ /dev/null @@ -1,188 +0,0 @@ -! (C) Copyright 1987- 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 LTDIRAD_MOD -CONTAINS -SUBROUTINE LTDIRAD(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC) - - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_GEOMETRY - -USE PREPSNM_MOD ,ONLY : PREPSNM -USE PRFI2AD_MOD ,ONLY : PRFI2AD -USE LDFOU2AD_MOD ,ONLY : LDFOU2AD -USE LEDIRAD_MOD ,ONLY : LEDIRAD -USE UVTVDAD_MOD -USE UPDSPAD_MOD ,ONLY : UPDSPAD - - -!**** *LTDIRAD* - Control of Direct Legendre transform step - adjoint - -! Purpose. -! -------- -! Tranform from Fourier space to spectral space, compute -! vorticity and divergence. - -!** Interface. -! ---------- -! *CALL* *LTDIRAD(...)* - -! Explicit arguments : -! -------------------- KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PSPVOR - spectral vorticity -! PSPDIV - spectral divergence -! PSPSCALAR - spectral scalar variables - -! Implicit arguments : None -! -------------------- - -! Method. -! ------- - -! Externals. -! ---------- -! PREPSNM - prepare REPSNM for wavenumber KM -! PRFI2AD - prepares the Fourier work arrays for model variables. -! LDFOU2AD - computations in Fourier space -! LEDIRAD - direct Legendre transform -! UVTVDAD - -! UPDSPAD - updating of spectral arrays (fields) - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 87-11-24 -! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite -! for uv formulation -! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies -! Modified 93-11-18 M. Hamrud - use only one Fourier buffer -! Modified 94-04-06 R. El khatib Full-POS implementation -! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div -! instead of u,v->vor,div -! MPP Group : 95-10-01 Support for Distributed Memory version -! K. YESSAD (AUGUST 1996): -! - Legendre transforms for transmission coefficients. -! Modified : 04/06/99 D.Salmond : change order of AIA and SIA -! R. El Khatib 12-Jul-2012 LDSPC2AD replaced by UVTVDAD -! ------------------------------------------------------------------ - -IMPLICIT NONE - - -! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KM -INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 - -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) -REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IFC, IIFC, IDGLU -INTEGER(KIND=JPIM) :: IUS, IUE, IVS, IVE, IVORS, IVORE, IDIVS, IDIVE - -! LOCAL REALS -REAL(KIND=JPRBT) :: ZSIA(KLED2,R%NDGNH), ZAIA(KLED2,R%NDGNH) -REAL(KIND=JPRBT) :: ZEPSNM(0:R%NTMAX+2) -REAL(KIND=JPRBT) :: ZOA1(R%NLED4,KLED2), ZOA2(R%NLED4,MAX(4*KF_UV,1)) - - -! ------------------------------------------------------------------ - -!* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM -! -------------------------------------- - - - - -! ------------------------------------------------------------------ - -!* 6. UPDATE SPECTRAL ARRAYS. -! ----------------------- - -CALL UPDSPAD(KM,KF_UV,KF_SCALARS,ZOA1,ZOA2, & - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC) - -! ------------------------------------------------------------------ - -!* 5. COMPUTE VORTICITY AND DIVERGENCE. -! --------------------------------- - -IF( KF_UV > 0 ) THEN - stop 'Error: code path not (yet) supported in GPU version' - !CALL PREPSNM(KM,KMLOC,ZEPSNM) - IUS = 1 - IUE = 2*KF_UV - IVS = 2*KF_UV+1 - IVE = 4*KF_UV - IVORS = 1 - IVORE = 2*KF_UV - IDIVS = 2*KF_UV+1 - IDIVE = 4*KF_UV -! SET PART OF ZOA1 CONTAINING U AND V TO 0. - ZOA1(:,IUS:IVE) = 0.0_JPRB - CALL UVTVDAD(KM,KF_UV,ZEPSNM,ZOA1(:,IUS:IUE),ZOA1(:,IVS:IVE),& - & ZOA2(:,IVORS:IVORE),ZOA2(:,IDIVS:IDIVE)) -ENDIF - -! ------------------------------------------------------------------ - -!* 4. DIRECT LEGENDRE TRANSFORM. -! -------------------------- -IFC = 2*KF_FS -IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) -IIFC = IFC -IF(KM == 0)THEN - IIFC = IFC/2 -ENDIF -CALL LEDIRAD(KM,KMLOC,IFC,IIFC,IDGLU,KLED2,ZAIA,ZSIA,ZOA1) - -! ------------------------------------------------------------------ - -!* 3. FOURIER SPACE COMPUTATIONS. -! --------------------------- - -CALL LDFOU2AD(KM,KF_UV,ZAIA,ZSIA) - -! ------------------------------------------------------------------ - -!* 2. PREPARE WORK ARRAYS. -! -------------------- - -CALL PRFI2AD(KM,KMLOC,KF_FS,ZAIA,ZSIA) - - -! ------------------------------------------------------------------ - -END SUBROUTINE LTDIRAD -END MODULE LTDIRAD_MOD - diff --git a/src/trans/gpu/internal/ltinv_ctl_mod.F90 b/src/trans/gpu/internal/ltinv_ctl_mod.F90 deleted file mode 100755 index 1a0712d11..000000000 --- a/src/trans/gpu/internal/ltinv_ctl_mod.F90 +++ /dev/null @@ -1,121 +0,0 @@ -! (C) Copyright 2000- 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 LTINV_CTL_MOD - CONTAINS - SUBROUTINE LTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2,& - & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) - - !**** *LTINV_CTL* - Control routine for inverse Legandre transform. - - ! Purpose. - ! -------- - ! Control routine for the inverse LEGENDRE transform - - !** Interface. - ! ---------- - ! CALL INV_TRANS_CTL(...) - ! KF_OUT_LT - number of fields coming out from inverse LT - ! KF_UV - local number of spectral u-v fields - ! KF_SCALARS - local number of scalar spectral fields - ! KF_SCDERS - local number of derivatives of scalar spectral fields - ! PSPVOR(:,:) - spectral vorticity (input) - ! PSPDIV(:,:) - spectral divergence (input) - ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) - ! KFLDPTRUV(:) - field pointer array for vor./div. - ! KFLDPTRSC(:) - field pointer array for PSPSCALAR - ! FSPGL_PROC - external procedure to be executed in fourier space - ! before transposition - - ! Method. - ! ------- - - ! Externals. - ! ---------- - ! - - ! Author. - ! ------- - ! Mats Hamrud *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 00-06-03 - - ! ------------------------------------------------------------------ - - USE PARKIND1 ,ONLY : JPIM ,JPRB - - USE TPM_GEN, only: nout - USE TPM_DIM ,ONLY : R - USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN - USE TPM_DISTR ,ONLY : D - USE TPM_GEOMETRY ,ONLY : G - - USE TPM_FLT - - USE LTINV_MOD ,ONLY : LTINV - USE TRMTOL_MOD ,ONLY : TRMTOL, TRMTOL_CUDAAWARE - - IMPLICIT NONE - - INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS - REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) - REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - EXTERNAL FSPGL_PROC - OPTIONAL FSPGL_PROC - - INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILEI2,IDIM1, i, j - - - !$ACC DATA CREATE(FOUBUF_IN) PRESENT(FOUBUF) - - CALL GSTATS(102,0) - ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS - IDIM1 = 2*KF_OUT_LT - IBLEN = D%NLENGT0B*2*KF_OUT_LT - - IF(KF_OUT_LT > 0) THEN - CALL GSTATS(1647,0) - - ! from PSPXXX to FOUBUF_IN - CALL LTINV(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& - & PSPVOR,PSPDIV,PSPSCALAR ,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) - - CALL GSTATS(1647,1) - ENDIF - CALL GSTATS(102,1) - - CALL GSTATS(152,0) - ! from FOUBUF_IN to FOUBUF -#ifdef USE_CUDA_AWARE_MPI_FT - WRITE(NOUT,*) 'ltinv_ctl:TRMTOL_CUDAAWARE' - CALL TRMTOL_CUDAAWARE(FOUBUF_IN,FOUBUF,2*KF_OUT_LT) -#else - !$ACC UPDATE HOST(FOUBUF_IN) - CALL TRMTOL(FOUBUF_IN,FOUBUF,2*KF_OUT_LT) - !$ACC UPDATE DEVICE(FOUBUF) -#endif - CALL GSTATS(152,1) - !$ACC END DATA - - ! ------------------------------------------------------------------ - - END SUBROUTINE LTINV_CTL - END MODULE LTINV_CTL_MOD diff --git a/src/trans/gpu/internal/ltinv_ctlad_mod.F90 b/src/trans/gpu/internal/ltinv_ctlad_mod.F90 deleted file mode 100755 index 4a3a1eff5..000000000 --- a/src/trans/gpu/internal/ltinv_ctlad_mod.F90 +++ /dev/null @@ -1,118 +0,0 @@ -! (C) Copyright 2000- 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 LTINV_CTLAD_MOD -CONTAINS -SUBROUTINE LTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2,& - & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) - -!**** *LTINV_CTLAD* - Control routine for inverse Legandre transform - adj. - -! Purpose. -! -------- -! Control routine for the inverse LEGENDRE transform - -!** Interface. -! ---------- -! CALL INV_TRANS_CTL(...) -! KF_OUT_LT - number of fields coming out from inverse LT -! KF_UV - local number of spectral u-v fields -! KF_SCALARS - local number of scalar spectral fields -! KF_SCDERS - local number of derivatives of scalar spectral fields -! PSPVOR(:,:) - spectral vorticity (input) -! PSPDIV(:,:) - spectral divergence (input) -! PSPSCALAR(:,:) - spectral scalarvalued fields (input) -! KFLDPTRUV(:) - field pointer array for vor./div. -! KFLDPTRSC(:) - field pointer array for PSPSCALAR -! FSPGL_PROC - external procedure to be executed in fourier space -! before transposition - -! Method. -! ------- - -! Externals. -! ---------- -! - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-06-03 - -! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPIM ,JPRB - -USE TPM_GEN ,ONLY : LALLOPERM -!USE TPM_DIM -USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN -USE TPM_DISTR ,ONLY : D -USE LTINVAD_MOD ,ONLY : LTINVAD -USE TRLTOM_MOD ,ONLY : TRLTOM - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC3B(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSC2(:,:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) -EXTERNAL FSPGL_PROC -OPTIONAL FSPGL_PROC - -INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILEI2,IDIM1 - -! ------------------------------------------------------------------ - -ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS -IDIM1 = 2*KF_OUT_LT -IBLEN = D%NLENGT0B*2*KF_OUT_LT -IF (ALLOCATED(FOUBUF_IN)) THEN - IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN - DEALLOCATE(FOUBUF_IN) - ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) - ENDIF -ELSE - ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) -ENDIF -CALL GSTATS(180,0) -CALL TRLTOM(FOUBUF,FOUBUF_IN,2*KF_OUT_LT) -CALL GSTATS(180,1) -IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) - -CALL GSTATS(104,0) -CALL GSTATS(1648,0) -IF(KF_OUT_LT > 0) THEN -!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) - DO JM=1,D%NUMP - IM = D%MYMS(JM) - CALL LTINVAD(IM,JM,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) - ENDDO -!$OMP END PARALLEL DO -ENDIF -CALL GSTATS(1648,1) - -IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) -CALL GSTATS(104,1) - -! ------------------------------------------------------------------ - -END SUBROUTINE LTINV_CTLAD -END MODULE LTINV_CTLAD_MOD diff --git a/src/trans/gpu/internal/ltinv_mod.F90 b/src/trans/gpu/internal/ltinv_mod.F90 index 3ee42f64c..1c1c69466 100755 --- a/src/trans/gpu/internal/ltinv_mod.F90 +++ b/src/trans/gpu/internal/ltinv_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,307 +10,383 @@ ! MODULE LTINV_MOD - CONTAINS - SUBROUTINE LTINV(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE TPM_DIM ,ONLY : R - USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B, foubuf_in - USE TPM_FLT - USE TPM_GEOMETRY - USE TPM_DISTR ,ONLY : D - use tpm_gen, only: nout - !USE PRLE1_MOD - USE PREPSNM_MOD ,ONLY : PREPSNM - USE PRFI1B_MOD ,ONLY : PRFI1B - USE VDTUV_MOD ,ONLY : VDTUV - USE SPNSDE_MOD ,ONLY : SPNSDE - USE LEINV_MOD ,ONLY : LEINV - USE ASRE1B_MOD ,ONLY : ASRE1B - USE FSPGL_INT_MOD ,ONLY : FSPGL_INT - USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS - use ieee_arithmetic - !USE TPM_FIELDS ,ONLY : F,ZIA,ZSOA1,ZAOA1,ISTAN,ISTAS,ZEPSNM - USE TPM_FIELDS ,ONLY : F,ZIA,ZSOA1,ZAOA1,ZEPSNM - - - !**** *LTINV* - Inverse Legendre transform - ! - ! Purpose. - ! -------- - ! Tranform from Laplace space to Fourier space, compute U and V - ! and north/south derivatives of state variables. - - !** Interface. - ! ---------- - ! *CALL* *LTINV(...) - - ! Explicit arguments : - ! -------------------- - ! KM - zonal wavenumber - ! KMLOC - local zonal wavenumber - ! PSPVOR - spectral vorticity - ! PSPDIV - spectral divergence - ! PSPSCALAR - spectral scalar variables - - ! Implicit arguments : The Laplace arrays of the model. - ! -------------------- The values of the Legendre polynomials - ! The grid point arrays of the model - ! Method. - ! ------- - - ! Externals. - ! ---------- - - ! PREPSNM - prepare REPSNM for wavenumber KM - ! PRFI1B - prepares the spectral fields - ! VDTUV - compute u and v from vorticity and divergence - ! SPNSDE - compute north-south derivatives - ! LEINV - Inverse Legendre transform - ! ASRE1 - recombination of symmetric/antisymmetric part - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - ! Temperton, 1991, MWR 119 p1303 - - ! Author. - ! ------- - ! Mats Hamrud *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 00-02-01 From LTINV in IFS CY22R1 - ! ------------------------------------------------------------------ - + USE ALLOCATOR_MOD + IMPLICIT NONE - - - INTERFACE - SUBROUTINE cudaProfilerStart() BIND(C,name='cudaProfilerStart') - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT - IMPLICIT NONE - END SUBROUTINE cudaProfilerStart - END INTERFACE - - INTERFACE - SUBROUTINE cudaProfilerStop() BIND(C,name='cudaProfilerStop') - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT - IMPLICIT NONE - END SUBROUTINE cudaProfilerStop - END INTERFACE - - - INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT - INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV - INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS - INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS - INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 - INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 - - REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) - REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) - INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - - - EXTERNAL FSPGL_PROC - OPTIONAL FSPGL_PROC - - !REAL(KIND=JPRBT) :: ZEPSNM(d%nump,0:R%NTMAX+2) - - INTEGER(KIND=JPIM) :: IFC, ISTA, IIFC, IDGLU - INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU - INTEGER(KIND=JPIM) :: IFIRST, ILAST, IDIM1,IDIM2,IDIM3,J3 - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - !CHARACTER(LEN=10) :: CLHOOK - - - INTEGER(KIND=JPIM) :: KM - INTEGER(KIND=JPIM) :: KMLOC - - - !call cudaProfilerStart - - - ! ------------------------------------------------------------------ - - !* 1. PERFORM LEGENDRE TRANFORM. - ! -------------------------- - - !WRITE(CLHOOK,FMT='(A,I4.4)') 'LTINV_',KM - IF (LHOOK) CALL DR_HOOK('LTINV_MOD',0,ZHOOK_HANDLE) - - ! ------------------------------------------------------------------ - - - !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. - ! ---------------------------------------------- - - IFIRST = 1 - ILAST = 0 - - !* 1. PREPARE ZEPSNM. - ! --------------- - - !IF ( KF_UV > 0 .OR. KF_SCDERS > 0 ) THEN - ! CALL PREPSNM(ZEPSNM) - ! !$ACC update host(ZEPSNM) - !ENDIF - -! COPY FROM PSPXXXX TO ZIA - - IF (KF_UV > 0) THEN - IVORL = 1 - IVORU = 2*KF_UV - IDIVL = 2*KF_UV+1 - IDIVU = 4*KF_UV - IUL = 4*KF_UV+1 - IUU = 6*KF_UV - IVL = 6*KF_UV+1 - IVU = 8*KF_UV - - IDIM2=UBOUND(PSPVOR,2) - CALL GSTATS(431,0) - !$ACC DATA COPYIN(PSPVOR,PSPDIV) - CALL GSTATS(431,1) - CALL PRFI1B(ZIA(IVORL:IVORU,:,:),PSPVOR,KF_UV,IDIM2,KFLDPTRUV) - CALL PRFI1B(ZIA(IDIVL:IDIVU,:,:),PSPDIV,KF_UV,IDIM2,KFLDPTRUV) - !$ACC END DATA - - ! ------------------------------------------------------------------ - - CALL VDTUV(KF_UV,ZEPSNM,ZIA(IVORL:IVORU,:,:),ZIA(IDIVL:IDIVU,:,:),& - & ZIA(IUL:IUU,:,:),ZIA(IVL:IVU,:,:)) - ILAST = ILAST+8*KF_UV - - ENDIF - - IF(KF_SCALARS > 0)THEN - IF(PRESENT(PSPSCALAR)) THEN - IFIRST = ILAST+1 - ILAST = IFIRST - 1 + 2*KF_SCALARS - - IDIM2=UBOUND(PSPSCALAR,2) - CALL GSTATS(431,0) - !$ACC DATA COPYIN(PSPSCALAR) - CALL GSTATS(431,1) - CALL PRFI1B(ZIA(IFIRST:ILAST,:,:),PSPSCALAR(:,:),KF_SCALARS,IDIM2,KFLDPTRSC) - !$ACC END DATA + + PRIVATE + PUBLIC :: LTINV, LTINV_HANDLE, PREPARE_LTINV + + TYPE LTINV_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPIA_AND_IN + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HOUTS_AND_OUTA + END TYPE + +CONTAINS + FUNCTION PREPARE_LTINV(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) RESULT(HLTINV) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD + USE TPM_DISTR, ONLY: D + USE TPM_DIM, ONLY: R + USE ISO_C_BINDING + USE LEINV_MOD + USE ALLOCATOR_MOD + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS + LOGICAL, INTENT(IN) :: LVORGP,LDIVGP,LSCDERS + + TYPE(LTINV_HANDLE) :: HLTINV + + INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ, IPIA_SZ + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE + INTEGER(KIND=JPIM) :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE + + REAL(KIND=JPRBT) :: ZPRBT_DUMMY + REAL(KIND=JPRD) :: ZPRD_DUMMY + + INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG + + ! # fields that are initially read. We always read vorticity + ! and divergence! Also keep in mind that we actually have 2X + ! this number of levels because real+complex + IF_READIN = 0 + IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence + IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence + IF_READIN = IF_READIN + KF_UV ! U + IF_READIN = IF_READIN + KF_UV ! V + IF_READIN = IF_READIN + KF_SCALARS ! Scalars + IF (LSCDERS) & + IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives + + IPIA_SZ = ALIGN(2*IF_READIN*(R%NSMAX+3)*D%NUMP*SIZEOF(ZPRBT_DUMMY),128) + + ! In Legendre space, we then ignore vorticity/divergence, if + ! they don't need to be transformed. + IF_LEG = IF_READIN + IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed + IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed + + CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& + IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) + + ! PIA + IALLOC_SZ = IPIA_SZ + ! ZINP + IALLOC_SZ = IALLOC_SZ + ALIGN(IIN_SIZE*SIZEOF(ZPRBT_DUMMY),128) + ! ZINP0 + IALLOC_SZ = IALLOC_SZ + ALIGN(IIN0_SIZE*SIZEOF(ZPRD_DUMMY),128) + + HLTINV%HPIA_AND_IN = RESERVE(ALLOCATOR, IALLOC_SZ) + + IALLOC_SZ = 0 + ! ZOUTA + IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*SIZEOF(ZPRBT_DUMMY),128) + ! ZOUTS + IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*SIZEOF(ZPRBT_DUMMY),128) + ! ZOUTA0 + IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT0_SIZE*SIZEOF(ZPRD_DUMMY),128) + ! ZOUTS0 + IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT0_SIZE*SIZEOF(ZPRD_DUMMY),128) + + HLTINV%HOUTS_AND_OUTA = RESERVE(ALLOCATOR, IALLOC_SZ) + END FUNCTION + + SUBROUTINE LTINV(ALLOCATOR,HLTINV,KF_UV,KF_SCALARS,& + & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & + & ZOUTS,ZOUTA,ZOUTS0,ZOUTA0) + + USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + + USE TPM_DIM ,ONLY : R + USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B, LSCDERS + USE TPM_FLT + USE TPM_GEOMETRY + USE TPM_DISTR ,ONLY : D + USE PRFI1B_MOD ,ONLY : PRFI1B + USE VDTUV_MOD ,ONLY : VDTUV + USE SPNSDE_MOD ,ONLY : SPNSDE + USE LEINV_MOD + USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + use ieee_arithmetic + USE TPM_FIELDS ,ONLY : F,ZEPSNM + USE MPL_MODULE ,ONLY : MPL_BARRIER + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + + !**** *LTINV* - Inverse Legendre transform + ! + ! Purpose. + ! -------- + ! Tranform from Laplace space to Fourier space, compute U and V + ! and north/south derivatives of state variables. + + !** Interface. + ! ---------- + ! *CALL* *LTINV(...) + + ! Explicit arguments : + ! -------------------- + ! KM - zonal wavenumber + ! KMLOC - local zonal wavenumber + ! PSPVOR - spectral vorticity + ! PSPDIV - spectral divergence + ! PSPSCALAR - spectral scalar variables + + ! Implicit arguments : The Laplace arrays of the model. + ! -------------------- The values of the Legendre polynomials + ! The grid point arrays of the model + ! Method. + ! ------- + + ! Externals. + ! ---------- + + ! PREPSNM - prepare REPSNM for wavenumber KM + ! PRFI1B - prepares the spectral fields + ! VDTUV - compute u and v from vorticity and divergence + ! SPNSDE - compute north-south derivatives + ! LEINV - Inverse Legendre transform + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + ! Temperton, 1991, MWR 119 p1303 + + ! Author. + ! ------- + ! Mats Hamrud *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 00-02-01 From LTINV in IFS CY22R1 + ! ------------------------------------------------------------------ + + IMPLICIT NONE + + + INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV + INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS + + REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) + REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) + REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: ZOUTS(:), ZOUTA(:) + REAL(KIND=JPRD), POINTER, INTENT(OUT) :: ZOUTS0(:), ZOUTA0(:) + + INTEGER(KIND=JPIM) :: IFIRST, J3 + + REAL(KIND=JPRB), POINTER :: PIA_L(:), PIA(:,:,:) + REAL(KIND=JPRB), POINTER :: PU(:,:,:), PV(:,:,:), PVOR(:,:,:), PDIV(:,:,:) + REAL(KIND=JPRB), POINTER :: PSCALARS(:,:,:), PSCALARS_NSDER(:,:,:) + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(LTINV_HANDLE), INTENT(IN) :: HLTINV + + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE + INTEGER(KIND=JPIM) :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE + + INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG + INTEGER(KIND=C_SIZE_T) :: IALLOC_POS, IALLOC_SZ + + REAL(KIND=JPRBT), POINTER :: ZINP(:) + REAL(KIND=JPRD), POINTER :: ZINP0(:) + + ! ------------------------------------------------------------------ + + !* 1. PERFORM LEGENDRE TRANFORM. + ! -------------------------- + + IF (LHOOK) CALL DR_HOOK('LTINV_MOD',0,ZHOOK_HANDLE) + + ! Get all pointers + IF_READIN = 0 + IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence + IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence + IF_READIN = IF_READIN + KF_UV ! U + IF_READIN = IF_READIN + KF_UV ! V + IF_READIN = IF_READIN + KF_SCALARS ! Scalars + IF (LSCDERS) & + IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives + + ! In Legendre space, we then ignore vorticity/divergence, if + ! they don't need to be transformed. + IF_LEG = IF_READIN + IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed + IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed + + CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& + IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) + + IALLOC_POS = 1 + + ! PIA + IALLOC_SZ = ALIGN(2*IF_READIN*(R%NTMAX+3)*D%NUMP*SIZEOF(PIA_L(1)),128) + CALL ASSIGN_PTR(PIA_L, GET_ALLOCATION(ALLOCATOR, HLTINV%HPIA_AND_IN),& + & IALLOC_POS, IALLOC_SZ) + CALL C_F_POINTER(C_LOC(PIA_L), PIA, (/ 2*IF_READIN, R%NTMAX+3, D%NUMP /)) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZINP + IALLOC_SZ = ALIGN(IIN_SIZE*SIZEOF(ZINP(1)),128) + CALL ASSIGN_PTR(ZINP, GET_ALLOCATION(ALLOCATOR, HLTINV%HPIA_AND_IN),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZINP0 + IALLOC_SZ = ALIGN(IIN0_SIZE*SIZEOF(ZINP0(1)),128) + CALL ASSIGN_PTR(ZINP0, GET_ALLOCATION(ALLOCATOR, HLTINV%HPIA_AND_IN),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + IALLOC_POS = 1 + + ! ZOUTA + IALLOC_SZ = ALIGN(IOUT_SIZE*SIZEOF(ZOUTA(1)),128) + CALL ASSIGN_PTR(ZOUTA, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZOUTS + IALLOC_SZ = ALIGN(IOUT_SIZE*SIZEOF(ZOUTS(1)),128) + CALL ASSIGN_PTR(ZOUTS, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZOUTA0 + IALLOC_SZ = ALIGN(IOUT0_SIZE*SIZEOF(ZOUTA0(1)),128) + CALL ASSIGN_PTR(ZOUTA0, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! ZOUTS0 + IALLOC_SZ = ALIGN(IOUT0_SIZE*SIZEOF(ZOUTS0(1)),128) + CALL ASSIGN_PTR(ZOUTS0, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS = IALLOC_POS + IALLOC_SZ + + ! Assign pointers do the different components of PIA + IFIRST = 0 + IF (.NOT. LVORGP .OR. LDIVGP) THEN + ! Usually we want to store vorticity first + PVOR => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV ! Vorticity + + PDIV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV ! Divergence ELSE - IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN - IFIRST = ILAST+1 - ILAST = IFIRST-1+2*NF_SC2 - IDIM2=UBOUND(PSPSC2,2) - CALL GSTATS(431,0) - !$ACC DATA COPYIN(PSPSC2) - CALL GSTATS(431,1) - CALL PRFI1B(ZIA(IFIRST:ILAST,:,:),PSPSC2(:,:),NF_SC2,IDIM2) - !$ACC END DATA - ENDIF - IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN - IDIM1=NF_SC3A - IDIM3=UBOUND(PSPSC3A,3) - IFIRST = ILAST+1 - ILAST = IFIRST-1+2*IDIM1 - IDIM2=UBOUND(PSPSC3A,2) - CALL GSTATS(431,0) - !$ACC DATA COPYIN(PSPSC3A) - CALL GSTATS(431,1) - DO J3=1,IDIM3 - CALL PRFI1B(ZIA(IFIRST:ILAST,:,:),PSPSC3A(:,:,J3),IDIM1,IDIM2) - ENDDO - !$ACC END DATA - ENDIF - IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN - IDIM1=NF_SC3B - IDIM3=UBOUND(PSPSC3B,3) - IDIM2=UBOUND(PSPSC3B,2) - CALL GSTATS(431,0) - !$ACC DATA COPYIN(PSPSC3B) - CALL GSTATS(431,1) - DO J3=1,IDIM3 - IFIRST = ILAST+1 - ILAST = IFIRST-1+2*IDIM1 - - CALL PRFI1B(ZIA(IFIRST:ILAST,:,:),PSPSC3B(:,:,J3),IDIM1,IDIM2) - ENDDO - !$ACC END DATA + ! Except if we want to translate Vorticity but not Divergence, we should have Divergence first + ! Then we have all buffers that move on in a contiguous buffer + PDIV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV ! Divergence + + PVOR => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV ! Vorticity + ENDIF + PU => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV ! U + PV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) + IFIRST = IFIRST + 2*KF_UV ! V + PSCALARS => PIA(IFIRST+1:IFIRST+2*KF_SCALARS,:,:) + IFIRST = IFIRST + 2*KF_SCALARS ! Scalars + IF (LSCDERS) THEN + PSCALARS_NSDER => PIA(IFIRST+1:IFIRST+2*KF_SCALARS,:,:) + IFIRST = IFIRST + 2*KF_SCALARS ! Scalars NS Derivatives + ENDIF + + ! ------------------------------------------------------------------ + + + !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. + ! ---------------------------------------------- + + IF (LSYNC_TRANS) THEN + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) + ENDIF + CALL GSTATS(422,0) + !$ACC DATA COPYIN(PSPVOR,PSPDIV) IF(KF_UV > 0) + !$ACC DATA COPYIN(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) + !$ACC DATA COPYIN(PSPSC2) IF(NF_SC2 > 0) + !$ACC DATA COPYIN(PSPSC3A) IF(NF_SC3A > 0) + !$ACC DATA COPYIN(PSPSC3B) IF(NF_SC3B > 0) + IF (LSYNC_TRANS) THEN + CALL GSTATS(442,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(442,1) + ENDIF + CALL GSTATS(422,1) + + IF (KF_UV > 0) THEN + CALL PRFI1B(PVOR,PSPVOR,KF_UV,UBOUND(PSPVOR,2)) + CALL PRFI1B(PDIV,PSPDIV,KF_UV,UBOUND(PSPDIV,2)) + + ! Compute U and V for VOR and DIV + CALL VDTUV(KF_UV,ZEPSNM,PVOR,PDIV,PU,PV) + ENDIF + + IF (KF_SCALARS > 0) THEN + IF(PRESENT(PSPSCALAR)) THEN + CALL PRFI1B(PSCALARS,PSPSCALAR,KF_SCALARS,UBOUND(PSPSCALAR,2)) + ELSE + IFIRST = 1 + IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN + CALL PRFI1B(PSCALARS(IFIRST:IFIRST+2*NF_SC2-1,:,:),PSPSC2(:,:),NF_SC2,UBOUND(PSPSC2,2)) + IFIRST = IFIRST+2*NF_SC2 + ENDIF + IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN + DO J3=1,UBOUND(PSPSC3A,3) + CALL PRFI1B(PSCALARS(IFIRST:IFIRST+2*NF_SC3A-1,:,:),PSPSC3A(:,:,J3),NF_SC3A,UBOUND(PSPSC3A,2)) + IFIRST = IFIRST+2*NF_SC3A + ENDDO + ENDIF + IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN + DO J3=1,UBOUND(PSPSC3B,3) + CALL PRFI1B(PSCALARS(IFIRST:IFIRST+2*NF_SC3B-1,:,:),PSPSC3B(:,:,J3),NF_SC3B,UBOUND(PSPSC3B,2)) + IFIRST = IFIRST+2*NF_SC3B + ENDDO + ENDIF + IF(IFIRST-1 /= 2*KF_SCALARS) THEN + WRITE(0,*) 'LTINV:KF_SCALARS,IFIRST',KF_SCALARS,IFIRST + CALL ABORT_TRANS('LTINV_MOD:IFIRST /= 2*KF_SCALARS') + ENDIF ENDIF ENDIF - IF(ILAST /= 8*KF_UV+2*KF_SCALARS) THEN - WRITE(0,*) 'LTINV:KF_UV,KF_SCALARS,ILAST ',KF_UV,KF_SCALARS,ILAST - CALL ABORT_TRANS('LTINV_MOD:ILAST /= 8*KF_UV+2*KF_SCALARS') + !$ACC END DATA + !$ACC END DATA + !$ACC END DATA + !$ACC END DATA + !$ACC END DATA + + ! Compute NS derivatives if needed + IF (LSCDERS) THEN + CALL SPNSDE(KF_SCALARS,ZEPSNM,PSCALARS,PSCALARS_NSDER) ENDIF - ENDIF - - IF (KF_SCDERS > 0) THEN - ! stop 'Error: code path not (yet) supported in GPU version' - ISL = 2*(4*KF_UV)+1 - ISU = ISL+2*KF_SCALARS-1 - IDL = 2*(4*KF_UV+KF_SCALARS)+1 - IDU = IDL+2*KF_SCDERS-1 - CALL SPNSDE(KF_SCALARS,ZEPSNM,ZIA(ISL:ISU,:,:),ZIA(IDL:IDU,:,:)) - ENDIF - - ! ------------------------------------------------------------------ - - - !* 4. INVERSE LEGENDRE TRANSFORM. - ! --------------------------- - - ! FROM ZIA TO ZAOA1 and ZSOA1 - - ISTA = 1 - IFC = 2*KF_OUT_LT - IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN - ISTA = ISTA+2*KF_UV - ENDIF - IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN - ISTA = ISTA+2*KF_UV - ENDIF - - IF( KF_OUT_LT > 0 ) THEN - !call cudaProfilerStart - CALL LEINV(IFC,KF_OUT_LT,ZIA(ISTA:ISTA+IFC-1,:,:),ZAOA1,ZSOA1) - !call cudaProfilerStop - - ! ------------------------------------------------------------------ - - !* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. - ! -------------------------------------------- - - !FROM ZAOA1/ZSOA to FOUBUF_IN - - !CALL ASRE1B(KF_OUT_LT,ZAOA1,ZSOA1,ISTAN,ISTAS) - CALL ASRE1B(KF_OUT_LT,ZAOA1,ZSOA1) - ! ------------------------------------------------------------------ - - ! 6. OPTIONAL COMPUTATIONS IN FOURIER SPACE - - - IF(PRESENT(FSPGL_PROC)) THEN - stop 'Error: SPGL_PROC is not (yet) optimized in GPU version' - CALL FSPGL_INT(KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,FSPGL_PROC,& - & KFLDPTRUV,KFLDPTRSC) - ENDIF - - ENDIF - IF (LHOOK) CALL DR_HOOK('LTINV_MOD',1,ZHOOK_HANDLE) - ! ------------------------------------------------------------------ - - !call cudaProfilerStop - + + ! ------------------------------------------------------------------ + + + !* 4. INVERSE LEGENDRE TRANSFORM. + ! --------------------------- + + ! Legendre transforms. When converting PIA into ZOUT, we ignore the first entries of LEINV. + ! This is because vorticity and divergence is not necessarily converted to GP space. + CALL LEINV(PIA(2*(IF_READIN-IF_LEG)+1:IF_READIN,:,:),ZINP,ZINP0,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,IF_LEG) + + IF (LHOOK) CALL DR_HOOK('LTINV_MOD',1,ZHOOK_HANDLE) + ! ------------------------------------------------------------------ END SUBROUTINE LTINV - END MODULE LTINV_MOD - +END MODULE LTINV_MOD + diff --git a/src/trans/gpu/internal/ltinvad_mod.F90 b/src/trans/gpu/internal/ltinvad_mod.F90 deleted file mode 100755 index 2de610e71..000000000 --- a/src/trans/gpu/internal/ltinvad_mod.F90 +++ /dev/null @@ -1,239 +0,0 @@ -! (C) Copyright 2000- 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 LTINVAD_MOD -CONTAINS -SUBROUTINE LTINVAD(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B -USE TPM_GEOMETRY - -!USE PRLE1AD_MOD -USE PREPSNM_MOD ,ONLY : PREPSNM -USE PRFI1BAD_MOD ,ONLY : PRFI1BAD -USE VDTUVAD_MOD ,ONLY : VDTUVAD -USE SPNSDEAD_MOD ,ONLY : SPNSDEAD -USE LEINVAD_MOD ,ONLY : LEINVAD -USE ASRE1BAD_MOD ,ONLY : ASRE1BAD -!USE FSPGL_INT_MOD - - -!**** *LTINVAD* - Inverse Legendre transform - -! Purpose. -! -------- -! Tranform from Laplace space to Fourier space, compute U and V -! and north/south derivatives of state variables. - -!** Interface. -! ---------- -! *CALL* *LTINVAD(...) - -! Explicit arguments : -! -------------------- -! KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PSPVOR - spectral vorticity -! PSPDIV - spectral divergence -! PSPSCALAR - spectral scalar variables - -! Implicit arguments : The Laplace arrays of the model. -! -------------------- The values of the Legendre polynomials -! The grid point arrays of the model -! Method. -! ------- - -! Externals. -! ---------- -! PRLE1AD - prepares the Legendre polonymials -! PREPSNM - prepare REPSNM for wavenumber KM -! PRFI1AD - prepares the spectral fields -! VDTUVAD - compute u and v from vorticity and divergence -! SPNSDEAD- compute north-south derivatives -! LEINVAD - Inverse Legendre transform -! ASRE1AD - recombination of symmetric/antisymmetric part - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS -! Temperton, 1991, MWR 119 p1303 - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From LTINVAD in IFS CY22R1 -! ------------------------------------------------------------------ - -IMPLICIT NONE - - -INTEGER(KIND=JPIM), INTENT(IN) :: KM -INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS -INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 -INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 - -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) -REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) -EXTERNAL FSPGL_PROC -OPTIONAL FSPGL_PROC - -REAL(KIND=JPRB) :: ZIA(R%NLEI1,KLEI2) -REAL(KIND=JPRBT) :: ZEPSNM(0:R%NTMAX+2) -REAL(KIND=JPRBT) :: ZSOA1(KDIM1,R%NLEI3),ZAOA1(KDIM1,R%NLEI3) - - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IFC, ISTA, IIFC, IDGLU -INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU -INTEGER(KIND=JPIM) :: ILAST,IFIRST,IDIM1,IDIM3,J3 - -! LOCAL LOGICAL SCALARS - -! LOCAL REAL SCALARS - -! ------------------------------------------------------------------ - -!* 1. PREPARE AND ZEPSNM. -! ------------------- - -stop 'Error: code path not (yet) supported in GPU version' -!CALL PREPSNM(KM,KMLOC,ZEPSNM) - -! ------------------------------------------------------------------ -! 6. OPTIONAL COMPUTATIONS IN FOURIER SPACE - -!IF(PRESENT(FSPGL_PROC)) THEN -! CALL FSPGL_INT(KM,KMLOC,FSPGL_PROC) -!ENDIF - -! ------------------------------------------------------------------ - -!* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. -! -------------------------------------------- - -CALL ASRE1BAD(KF_OUT_LT,KM,KMLOC,ZAOA1,ZSOA1) - -! ------------------------------------------------------------------ - -!* 4. INVERSE LEGENDRE TRANSFORM. -! --------------------------- - - -ISTA = 1 -IFC = 2*KF_OUT_LT -IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN - ISTA = ISTA+2*KF_UV -ENDIF -IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN - ISTA = ISTA+2*KF_UV -ENDIF - -ZIA(:,ISTA:ISTA+IFC-1) = 0.0_JPRBT - -IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) -IIFC=IFC -IF(KM == 0)THEN - IIFC=IFC/2 -ENDIF -CALL LEINVAD(KM,KMLOC,IFC,IIFC,KF_OUT_LT,IDGLU,ZIA(:,ISTA:ISTA+IFC-1),ZAOA1,ZSOA1) - -! ------------------------------------------------------------------ - -!* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. -! ---------------------------------------------- - -ZIA(:,1:ISTA-1) = 0.0_JPRBT - -IFIRST = 1 -ILAST = 4*KF_UV -IF (KF_UV > 0) THEN - IVORL = 1 - IVORU = 2*KF_UV - IDIVL = 2*KF_UV+1 - IDIVU = 4*KF_UV - IUL = 4*KF_UV+1 - IUU = 6*KF_UV - IVL = 6*KF_UV+1 - IVU = 8*KF_UV - CALL VDTUVAD(KM,KF_UV,ZEPSNM,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& - & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU)) - CALL PRFI1BAD(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV,KFLDPTRUV) - CALL PRFI1BAD(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV,KFLDPTRUV) - ILAST = ILAST+4*KF_UV -ENDIF - -IF (KF_SCDERS > 0) THEN - ISL = 2*(4*KF_UV)+1 - ISU = ISL+2*KF_SCALARS-1 - IDL = 2*(4*KF_UV+KF_SCALARS)+1 - IDU = IDL+2*KF_SCDERS-1 - CALL SPNSDEAD(KM,KF_SCALARS,ZEPSNM,ZIA(:,ISL:ISU),ZIA(:,IDL:IDU)) -ENDIF - -IF(KF_SCALARS > 0)THEN - IF(PRESENT(PSPSCALAR)) THEN - IFIRST = ILAST+1 - ILAST = IFIRST - 1 + 2*KF_SCALARS - CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) - ELSE - IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN - IFIRST = ILAST+1 - ILAST = IFIRST-1+2*NF_SC2 - CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSC2(:,:),NF_SC2) - ENDIF - IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN - IDIM1=NF_SC3A - IDIM3=UBOUND(PSPSC3A,3) - DO J3=1,IDIM3 - IFIRST = ILAST+1 - ILAST = IFIRST-1+2*IDIM1 - CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSC3A(:,:,J3),IDIM1) - ENDDO - ENDIF - IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN - IDIM1=NF_SC3B - IDIM3=UBOUND(PSPSC3B,3) - DO J3=1,IDIM3 - IFIRST = ILAST+1 - ILAST = IFIRST-1+2*IDIM1 - CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSC3B(:,:,J3),IDIM1) - ENDDO - ENDIF - ENDIF -ENDIF - - -! ------------------------------------------------------------------ - - -END SUBROUTINE LTINVAD -END MODULE LTINVAD_MOD - - - - diff --git a/src/trans/gpu/internal/prfi1ad_mod.F90 b/src/trans/gpu/internal/prfi1ad_mod.F90 deleted file mode 100755 index 607ef63c9..000000000 --- a/src/trans/gpu/internal/prfi1ad_mod.F90 +++ /dev/null @@ -1,112 +0,0 @@ -! (C) Copyright 2000- 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 PRFI1AD_MOD -CONTAINS -SUBROUTINE PRFI1AD(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& - & KFLDPTRUV,KFLDPTRSC) - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -!USE TPM_DISTR -!USE TPM_TRANS - -USE PRFI1BAD_MOD ,ONLY : PRFI1BAD - - -!**** *PRFI1AD* - Prepare spectral fields for inverse Legendre transform - -! Purpose. -! -------- -! To extract the spectral fields for a specific zonal wavenumber -! and put them in an order suitable for the inverse Legendre . -! tranforms.The ordering is from NSMAX to KM for better conditioning. -! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing -! u,v and derivatives in spectral space. - -!** Interface. -! ---------- -! *CALL* *PRFI1AD(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR - -! Explicit arguments : KM - zonal wavenumber -! ------------------ PIA - spectral components for transform -! PSPVOR - vorticity -! PSPDIV - divergence -! PSPSCALAR - scalar variables - -! Implicit arguments : None. -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From PRFI1AD in IFS CY22R1 - -! ------------------------------------------------------------------ - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KM,KF_UV,KF_SCALARS -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) , INTENT(IN) :: PIA(:,:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR - - -! ------------------------------------------------------------------ - -!* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. -! ------------------------------------ - -IFIRST = 1 -ILAST = 4*KF_UV - -!* 1.1 VORTICITY AND DIVERGENCE. - -IF(KF_UV > 0)THEN - IVOR = 1 - IDIV = 2*KF_UV+1 - CALL PRFI1BAD(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) - CALL PRFI1BAD(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) - ILAST = ILAST+4*KF_UV -ENDIF - -!* 1.2 SCALAR VARIABLES. - -IF(KF_SCALARS > 0)THEN - IFIRST = ILAST+1 - ILAST = IFIRST - 1 + 2*KF_SCALARS - CALL PRFI1BAD(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE PRFI1AD -END MODULE PRFI1AD_MOD - - diff --git a/src/trans/gpu/internal/prfi1b_mod.F90 b/src/trans/gpu/internal/prfi1b_mod.F90 index fc2f491ea..496ac3d57 100755 --- a/src/trans/gpu/internal/prfi1b_mod.F90 +++ b/src/trans/gpu/internal/prfi1b_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -72,7 +73,7 @@ SUBROUTINE PRFI1B(PIA,PSPEC,KFIELDS,KDIM,KFLDPTR) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS - INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF,IFLD + INTEGER(KIND=JPIM) :: II, INM, IR, JN, JFLD, ILCM, IASM0,IFLD ! ------------------------------------------------------------------ @@ -80,33 +81,31 @@ SUBROUTINE PRFI1B(PIA,PSPEC,KFIELDS,KDIM,KFLDPTR) !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- - !$ACC DATA & - !$ACC PRESENT(D_NUMP,R_NSMAX,D_MYMS,D_NASM0) & - !$ACC PRESENT(PIA) & - !$ACC PRESENT(PSPEC) + !$ACC DATA PRESENT(D_MYMS,D_NASM0,PIA,PSPEC) !$ACC DATA IF(PRESENT(KFLDPTR)) PRESENT(KFLDPTR) IF(PRESENT(KFLDPTR)) THEN - + PRINT *, "Not implemented" + STOP 4 !loop over wavenumber - !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,ILCM,IFLD,IOFF,IR,II,INM) + !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,ILCM,IFLD,IASM0,IR,II,INM) DO KMLOC=1,D_NUMP - DO J=1,R_NSMAX+1 + DO JN=1,R_NSMAX+1 DO JFLD=1,KFIELDS KM = D_MYMS(KMLOC) ILCM = R_NSMAX+1-KM IFLD = KFLDPTR(JFLD) - IF (J .LE. ILCM) THEN - IOFF = D_NASM0(KM) - INM = IOFF+(ILCM-J)*2 + IF (JN .LE. ILCM) THEN + IASM0 = D_NASM0(KM) + INM = IASM0+(ILCM-JN)*2 IR = 2*(JFLD-1)+1 II = IR+1 - PIA(IR,J+2,KMLOC) = PSPEC(iFLD,INM ) - PIA(II,J+2,KMLOC) = PSPEC(iFLD,INM+1) + PIA(IR,JN+2,KMLOC) = PSPEC(iFLD,INM ) + PIA(II,JN+2,KMLOC) = PSPEC(iFLD,INM+1) END IF ENDDO ENDDO @@ -126,45 +125,33 @@ SUBROUTINE PRFI1B(PIA,PSPEC,KFIELDS,KDIM,KFLDPTR) ! end loop over wavenumber END DO - ELSE +ELSE - !loop over wavenumber + !loop over wavenumber - !$ACC PARALLEL LOOP !!COLLAPSE(3) PRIVATE(KM,ILCM,IOFF,INM,IR,II) - DO KMLOC=1,D_NUMP - DO J=1,R_NSMAX+1 - DO JFLD=1,KFIELDS - KM = D_MYMS(KMLOC) - ILCM = R_NSMAX+1-KM - if (J .le. ILCM) then - IOFF = D_NASM0(KM) - INM = IOFF+(ILCM-J)*2 - IR = 2*(JFLD-1)+1 - II = IR+1 - IF( INM .LT. KDIM ) THEN - PIA(IR,J+2,KMLOC) = PSPEC(JFLD,INM ) - PIA(II,J+2,KMLOC) = PSPEC(JFLD,INM+1) - ENDIF - end if - ENDDO + !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,IASM0,INM) DEFAULT(NONE) + DO KMLOC=1,D_NUMP + DO JN=0,R_NSMAX+3 + DO JFLD=1,KFIELDS + KM = D_MYMS(KMLOC) + + IF (JN <= 1) THEN + PIA(2*JFLD-1,JN+1,KMLOC) = 0.0_JPRB + PIA(2*JFLD ,JN+1,KMLOC) = 0.0_JPRB + ELSEIF (JN <= R_NSMAX+2-KM) THEN + IASM0 = D_NASM0(KM) + INM = IASM0+((R_NSMAX+2-JN)-KM)*2 + PIA(2*JFLD-1,JN+1,KMLOC) = PSPEC(JFLD,INM ) + PIA(2*JFLD ,JN+1,KMLOC) = PSPEC(JFLD,INM+1) + ELSEIF (JN <= R_NSMAX+3-KM) THEN + PIA(2*JFLD-1,JN+1,KMLOC) = 0.0_JPRB + PIA(2*JFLD ,JN+1,KMLOC) = 0.0_JPRB + ENDIF ENDDO - - ! end loop over wavenumber - END DO + ENDDO + ENDDO - !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,ILCM) - DO KMLOC=1,D_NUMP - DO JFLD=1,2*KFIELDS - KM = D_MYMS(KMLOC) - ILCM = R_NSMAX+1-KM - PIA(JFLD,1,KMLOC) = 0.0_JPRB - PIA(JFLD,2,KMLOC) = 0.0_JPRB - PIA(JFLD,ILCM+3,KMLOC) = 0.0_JPRB - ENDDO - ! end loop over wavenumber - END DO - - END IF +END IF !$ACC END DATA !$ACC END DATA diff --git a/src/trans/gpu/internal/prfi1bad_mod.F90 b/src/trans/gpu/internal/prfi1bad_mod.F90 deleted file mode 100755 index 5ba45c863..000000000 --- a/src/trans/gpu/internal/prfi1bad_mod.F90 +++ /dev/null @@ -1,111 +0,0 @@ -! (C) Copyright 2000- 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 PRFI1BAD_MOD -CONTAINS -SUBROUTINE PRFI1BAD(KM,PIA,PSPEC,KFIELDS,KFLDPTR) - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -USE TPM_DIM ,ONLY : R -USE TPM_DISTR ,ONLY : D - - -!**** *PRFI1* - Prepare spectral fields for inverse Legendre transform - -! Purpose. -! -------- -! To extract the spectral fields for a specific zonal wavenumber -! and put them in an order suitable for the inverse Legendre . -! tranforms.The ordering is from NSMAX to KM for better conditioning. -! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing -! u,v and derivatives in spectral space. - -!** Interface. -! ---------- -! *CALL* *PRFI1BAD(...)* - -! Explicit arguments : KM - zonal wavenumber -! ------------------ PIA - spectral components for transform -! PSPEC - spectral array -! KFIELDS - number of fields - - -! Implicit arguments : None. -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From PRFI1BAD in IFS CY22R1 - -! ------------------------------------------------------------------ - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS -REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) -REAL(KIND=JPRB) ,INTENT(IN) :: PIA(:,:) -INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF, IFLD - - -! ------------------------------------------------------------------ - -!* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. -! -------------------------------------------------- - - -ILCM = R%NSMAX+1-KM -IOFF = D%NASM0(KM) - -IF(PRESENT(KFLDPTR)) THEN - DO JFLD=1,KFIELDS - IR = 2*(JFLD-1)+1 - II = IR+1 - IFLD = KFLDPTR(JFLD) - DO J=1,ILCM - INM = IOFF+(ILCM-J)*2 - PSPEC(IFLD,INM ) = PSPEC(IFLD,INM ) + PIA(J+2,IR) - PSPEC(IFLD,INM+1) = PSPEC(IFLD,INM+1) + PIA(J+2,II) - ENDDO - ENDDO -ELSE - DO J=1,ILCM - INM = IOFF+(ILCM-J)*2 -!DIR$ IVDEP -!OCL NOVREC - DO JFLD=1,KFIELDS - IR = 2*(JFLD-1)+1 - II = IR+1 - PSPEC(JFLD,INM ) = PSPEC(JFLD,INM ) + PIA(J+2,IR) - PSPEC(JFLD,INM+1) = PSPEC(JFLD,INM+1) + PIA(J+2,II) - ENDDO - ENDDO -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE PRFI1BAD -END MODULE PRFI1BAD_MOD diff --git a/src/trans/gpu/internal/prfi2_mod.F90 b/src/trans/gpu/internal/prfi2_mod.F90 deleted file mode 100755 index 913d3022e..000000000 --- a/src/trans/gpu/internal/prfi2_mod.F90 +++ /dev/null @@ -1,99 +0,0 @@ -! (C) Copyright 1987- 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 PRFI2_MOD - CONTAINS - SUBROUTINE PRFI2(KF_FS,PAIA,PSIA) - - !**** *PRFI2* - Prepare input work arrays for direct transform - - ! Purpose. - ! -------- - ! To extract the Fourier fields for a specific zonal wavenumber - ! and put them in an order suitable for the direct Legendre - ! tranforms, i.e. split into symmetric and anti-symmetric part. - - !** Interface. - ! ---------- - ! *CALL* *PRFI2(..) - - ! Explicit arguments : - ! -------------------- KM - zonal wavenumber - ! KMLOC - local zonal wavenumber - ! PAIA - antisymmetric part of Fourier - ! components for KM (output) - ! PSIA - symmetric part of Fourier - ! components for KM (output) - - ! Implicit arguments : The Grid point arrays of the model. - ! -------------------- - - ! Method. - ! ------- - - ! Externals. PRFI2B - basic copying routine - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! Mats Hamrud and Philippe Courtier *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 87-11-25 - ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite - ! for uv formulation - ! Modified : 93-03-19 D. Giard - CDCONF='T' - ! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' - ! Modified : 93-05-13 D. Giard - correction of the previous bug - ! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer - ! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' - ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div - ! instead of u,v->vor,div - ! MPP Group: 95-10-01 Support for Distributed Memory version - ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA - ! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - - !USE TPM_TRANS - - USE PRFI2B_MOD ,ONLY : PRFI2B - ! - - IMPLICIT NONE - - - ! DUMMY INTEGER SCALARS - INTEGER(KIND=JPIM) :: KM - INTEGER(KIND=JPIM) :: KMLOC - INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS - - - REAL(KIND=JPRBT) , INTENT(OUT) :: PSIA(:,:,:), PAIA(:,:,:) - - - ! LOCAL INTEGER SCALARS - - - ! ------------------------------------------------------------------ - - !* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. - ! ------------------------------------------- - -! CALL PRFI2B(KF_FS,PAIA,PSIA) - - ! ------------------------------------------------------------------ - - END SUBROUTINE PRFI2 - END MODULE PRFI2_MOD diff --git a/src/trans/gpu/internal/prfi2ad_mod.F90 b/src/trans/gpu/internal/prfi2ad_mod.F90 deleted file mode 100755 index ecea0aed4..000000000 --- a/src/trans/gpu/internal/prfi2ad_mod.F90 +++ /dev/null @@ -1,90 +0,0 @@ -! (C) Copyright 1987- 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 PRFI2AD_MOD -CONTAINS -SUBROUTINE PRFI2AD(KM,KMLOC,KF_FS,PAIA,PSIA) - -!**** *PRFI2AD* - Prepare input work arrays for direct transform - -! Purpose. -! -------- -! To extract the Fourier fields for a specific zonal wavenumber -! and put them in an order suitable for the direct Legendre -! tranforms, i.e. split into symmetric and anti-symmetric part. - -!** Interface. -! ---------- -! *CALL* *PRFI2AD(..) - -! Explicit arguments : -! -------------------- KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PAIA - antisymmetric part of Fourier -! components for KM (output) -! PSIA - symmetric part of Fourier -! components for KM (output) - -! Implicit arguments : The Grid point arrays of the model. -! -------------------- - -! Method. -! ------- - -! Externals. PRFI2ADB - basic copying routine -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 87-11-25 -! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite -! for uv formulation -! Modified : 93-03-19 D. Giard - CDCONF='T' -! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' -! Modified : 93-05-13 D. Giard - correction of the previous bug -! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer -! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' -! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div -! instead of u,v->vor,div -! MPP Group: 95-10-01 Support for Distributed Memory version -! Modified : 04/06/99 D.Salmond : change order of AIA and SIA -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE PRFI2BAD_MOD ,ONLY : PRFI2BAD -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM) , INTENT(IN) :: KM -INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS - -REAL(KIND=JPRBT) , INTENT(IN) :: PSIA(:,:), PAIA(:,:) - -! ------------------------------------------------------------------ - -!* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. -! ------------------------------------------- - -CALL PRFI2BAD(KF_FS,KM,KMLOC,PAIA,PSIA) - -! ------------------------------------------------------------------ - -END SUBROUTINE PRFI2AD -END MODULE PRFI2AD_MOD diff --git a/src/trans/gpu/internal/prfi2b_mod.F90 b/src/trans/gpu/internal/prfi2b_mod.F90 deleted file mode 100755 index 33962319f..000000000 --- a/src/trans/gpu/internal/prfi2b_mod.F90 +++ /dev/null @@ -1,116 +0,0 @@ -! (C) Copyright 1990- 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 PRFI2B_MOD - CONTAINS - SUBROUTINE PRFI2B(KFIELD,PAIA,KMODE) - - !**** *PRFI2B* - Prepare input work arrays for direct transform - - ! Purpose. - ! -------- - ! To extract the Fourier fields for a specific zonal wavenumber - ! and put them in an order suitable for the direct Legendre - ! tranforms, i.e. split into symmetric and anti-symmetric part. - - !** Interface. - ! ---------- - ! *CALL* *PRFI2B(..) - - ! Explicit arguments : - ! ------------------- KFIELD - number of fields - ! KM - zonal wavenumber - ! KMLOC - local zonal wavenumber - ! PAOA - antisymmetric part of Fourier - ! fields for zonal wavenumber KM - ! PSOA - symmetric part of Fourier - ! fields for zonal wavenumber KM - - ! Implicit arguments : FOUBUF in TPM_TRANS - ! -------------------- - - ! Method. - ! ------- - - ! Externals. None. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! Mats Hamrud and Philippe Courtier *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 90-07-01 - ! MPP Group: 95-10-01 Support for Distributed Memory version - ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA - ! ------------------------------------------------------------------ - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - - USE TPM_DIM ,ONLY : R, R_NDGNH, R_NDGL - USE TPM_TRANS ,ONLY : FOUBUF - USE TPM_GEOMETRY ,ONLY : G, G_NDGLU - USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS,D_NSTAGT1B,D_NPROCL,D_NPNTGTB1,MYPROC - ! - - IMPLICIT NONE - - INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD - INTEGER(KIND=JPIM),INTENT(IN) :: KMODE - INTEGER(KIND=JPIM) :: KM,KMLOC - REAL(KIND=JPRBT) , INTENT(OUT) :: PAIA(:,:,:) -!! REAL(KIND=JPRBT) , INTENT(OUT) :: PSIA(:,:,:), PAIA(:,:,:) - - - ! LOCAL INTEGER SCALARS - INTEGER(KIND=JPIM) :: IGLS, ISL, JF, JGL, iunit - - INTEGER(KIND=JPIM) :: OFFSET1, OFFSET2 - - - ! ------------------------------------------------------------------ - - !* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. - ! ------------------------------------------------ - - -!$ACC DATA PRESENT(PAIA,FOUBUF, D_NPNTGTB1,D_NSTAGT1B,D_MYMS,R_NDGL,R_NDGNH,G_NDGLU,D_NPROCL) - -!$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2) -DO KMLOC=1,D_NUMP - DO JGL=1,R_NDGNH - DO JF=1,KFIELD*2 - KM = D_MYMS(KMLOC) - ISL = MAX(R_NDGNH-G_NDGLU(KM)+1,1) - if (JGL .ge. ISL) then - IGLS = R_NDGL+1-JGL - OFFSET1 = (D_NSTAGT1B(D_NPROCL(JGL) )+D_NPNTGTB1(KMLOC,JGL ))*2*KFIELD - OFFSET2 = (D_NSTAGT1B(D_NPROCL(IGLS))+D_NPNTGTB1(KMLOC,IGLS))*2*KFIELD - IF( KMODE == -1 ) THEN - PAIA(JF,JGL,KMLOC) = FOUBUF(OFFSET1+JF)-FOUBUF(OFFSET2+JF) - ELSE - PAIA(JF,JGL,KMLOC) = FOUBUF(OFFSET1+JF)+FOUBUF(OFFSET2+JF) -! PSIA(JF,JGL,KMLOC) = FOUBUF(OFFSET1+JF)+FOUBUF(OFFSET2+JF) - ENDIF - end if - ENDDO - ENDDO -END DO - -!$ACC END DATA - - ! ------------------------------------------------------------------ - - END SUBROUTINE PRFI2B - END MODULE PRFI2B_MOD diff --git a/src/trans/gpu/internal/prfi2bad_mod.F90 b/src/trans/gpu/internal/prfi2bad_mod.F90 deleted file mode 100755 index 85aca6259..000000000 --- a/src/trans/gpu/internal/prfi2bad_mod.F90 +++ /dev/null @@ -1,98 +0,0 @@ -! (C) Copyright 1990- 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 PRFI2BAD_MOD -CONTAINS -SUBROUTINE PRFI2BAD(KFIELD,KM,KMLOC,PAIA,PSIA) - -!**** *PRFI2BAD* - Prepare input work arrays for direct transform - -! Purpose. -! -------- -! To extract the Fourier fields for a specific zonal wavenumber -! and put them in an order suitable for the direct Legendre -! tranforms, i.e. split into symmetric and anti-symmetric part. - -!** Interface. -! ---------- -! *CALL* *PRFI2BAD(..) - -! Explicit arguments : -! ------------------- KFIELD - number of fields -! KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PAOA - antisymmetric part of Fourier -! fields for zonal wavenumber KM -! PSOA - symmetric part of Fourier -! fields for zonal wavenumber KM - -! Implicit arguments : FOUBUF in TPM_TRANS -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 90-07-01 -! MPP Group: 95-10-01 Support for Distributed Memory version -! Modified : 04/06/99 D.Salmond : change order of AIA and SIA -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_TRANS ,ONLY : FOUBUF -USE TPM_GEOMETRY ,ONLY : G -USE TPM_DISTR ,ONLY : D -! - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC -REAL(KIND=JPRBT) , INTENT(IN) :: PSIA(:,:), PAIA(:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IGLS, ISL, ISTAN, ISTAS, JF, JGL - - -! ------------------------------------------------------------------ - -!* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. -! ------------------------------------------------ - -ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) - -DO JGL=ISL,R%NDGNH - IGLS = R%NDGL+1-JGL - ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD - ISTAS = (D%NSTAGT1B(D%NPROCL(IGLS))+D%NPNTGTB1(KMLOC,IGLS))*2*KFIELD -!DIR$ IVDEP -!OCL NOVREC - DO JF=1,KFIELD*2 - FOUBUF(ISTAN+JF) = PSIA(JF,JGL)+PAIA(JF,JGL) - FOUBUF(ISTAS+JF) = PSIA(JF,JGL)-PAIA(JF,JGL) - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE PRFI2BAD -END MODULE PRFI2BAD_MOD diff --git a/src/trans/gpu/internal/set_resol_mod.F90 b/src/trans/gpu/internal/set_resol_mod.F90 index 61486f6c0..e317e89a5 100755 --- a/src/trans/gpu/internal/set_resol_mod.F90 +++ b/src/trans/gpu/internal/set_resol_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -22,7 +23,6 @@ SUBROUTINE SET_RESOL(KRESOL,LDSETUP) #ifdef WITH_FFTW USE TPM_FFTW ,ONLY : TW, FFTW_RESOL #endif -USE TPM_FFTC ,ONLY : TC, FFTC_RESOL USE TPM_FLT USE TPM_CTL ,ONLY : C, CTL_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS @@ -68,7 +68,6 @@ SUBROUTINE SET_RESOL(KRESOL,LDSETUP) #ifdef WITH_FFTW TW => FFTW_RESOL(NCUR_RESOL) #endif - TC => FFTC_RESOL(NCUR_RESOL) S => FLT_RESOL(NCUR_RESOL) C => CTL_RESOL(NCUR_RESOL) ENDIF diff --git a/src/trans/gpu/internal/spnsde_mod.F90 b/src/trans/gpu/internal/spnsde_mod.F90 index 6d9a649c1..6affe2154 100755 --- a/src/trans/gpu/internal/spnsde_mod.F90 +++ b/src/trans/gpu/internal/spnsde_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -14,8 +15,7 @@ SUBROUTINE SPNSDE(KF_SCALARS,PEPSNM,PF,PNSD) USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT USE TPM_GEN, only: nout -USE TPM_DIM ,ONLY : R -USE TPM_FIELDS ,ONLY : F +USE TPM_DIM ,ONLY : R, R_NTMAX USE TPM_DISTR ,ONLY : D !USE TPM_TRANS @@ -82,14 +82,11 @@ SUBROUTINE SPNSDE(KF_SCALARS,PEPSNM,PF,PNSD) REAL(KIND=JPRB), INTENT(OUT) :: PNSD(:,:,:) ! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IJ, ISKIP, J, JN,JI,ISMAX, IR, II -REAL(KIND=JPRBT) :: ZZEPSNM(-1:R%NSMAX+4) -REAL(KIND=JPRBT) :: ZN(-1:R%NTMAX+4) +INTEGER(KIND=JPIM) :: IJ, ISKIP, J, JN,JI, IR, II !$ACC DATA & -!$ACC CREATE (ZN,ZZEPSNM) & -!$ACC PRESENT (F,F%RN) & -!$ACC PRESENT (PEPSNM, PF, PNSD) +!$ACC PRESENT (D) & +!$ACC PRESENT (PEPSNM,PF,PNSD) ! ------------------------------------------------------------------ @@ -99,54 +96,30 @@ SUBROUTINE SPNSDE(KF_SCALARS,PEPSNM,PF,PNSD) !* 1.1 COMPUTE -ISMAX = R%NSMAX -!loop over wavenumber +!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IR,II,KM,JI) DEFAULT(NONE) DO KMLOC=1,D%NUMP - KM = D%MYMS(KMLOC) - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IJ) - DO JN=KM-1,ISMAX+2 - IJ = ISMAX+3-JN - ZN(IJ) = F%RN(JN) - IF( JN >= 0 ) THEN - ZZEPSNM(IJ) = PEPSNM(KMLOC,JN) - ELSE - ZZEPSNM(IJ) = 0 - ENDIF - !write(nout,*) 'deriv dy debug in ; ',JN, IJ, ZN(IJ),ZZEPSNM(IJ),PEPSNM(KMLOC,JN) - ENDDO - !$ACC KERNELS DEFAULT(NONE) - ZN(0) = F%RN(ISMAX+3) - !$ACC END KERNELS - - IF(KM == 0) THEN - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IR) - DO J=1,KF_SCALARS - IR = 2*J-1 - DO JI=2,ISMAX+3 - PNSD(IR,JI,KMLOC) = -ZN(JI+1)*ZZEPSNM(JI)*PF(IR,JI+1,KMLOC)+& - &ZN(JI-2)*ZZEPSNM(JI-1)*PF(IR,JI-1,KMLOC) - ENDDO - ENDDO - ELSE - - !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(IR,II) + DO JN=0,R_NTMAX+1 DO J=1,KF_SCALARS - DO JI=2,ISMAX+3-KM - IR = 2*J-1 - II = IR+1 - PNSD(IR,JI,KMLOC) = -ZN(JI+1)*ZZEPSNM(JI)*PF(IR,JI+1,KMLOC)+& - &ZN(JI-2)*ZZEPSNM(JI-1)*PF(IR,JI-1,KMLOC) - PNSD(II,JI,KMLOC) = -ZN(JI+1)*ZZEPSNM(JI)*PF(II,JI+1,KMLOC)+& - &ZN(JI-2)*ZZEPSNM(JI-1)*PF(II,JI-1,KMLOC) - !write(301,*) 'deriv dy debug 2nd; ',KMLOC,IR,II,JI,J,PNSD(IR,JI,KMLOC),PNSD(II,JI,KMLOC) - !call flush(301) - ENDDO + IR = 2*J-1 + II = IR+1 + KM = D%MYMS(KMLOC) + + IF(KM /= 0 .AND. JN >= KM) THEN + ! (DO JN=KN,R_NTMAX+1) + JI = R_NTMAX+3-JN + PNSD(IR,JI,KMLOC) = -(JN-1)*PEPSNM(KMLOC,JN)*PF(IR,JI+1,KMLOC)+& + &(JN+2)*PEPSNM(KMLOC,JN+1)*PF(IR,JI-1,KMLOC) + PNSD(II,JI,KMLOC) = -(JN-1)*PEPSNM(KMLOC,JN)*PF(II,JI+1,KMLOC)+& + &(JN+2)*PEPSNM(KMLOC,JN+1)*PF(II,JI-1,KMLOC) + + ELSEIF(KM == 0) THEN + ! (DO JN=0,R_NTMAX+1) + JI = R_NTMAX+3-JN + PNSD(IR,JI,KMLOC) = -(JN-1)*PEPSNM(KMLOC,JN)*PF(IR,JI+1,KMLOC)+& + &(JN+2)*PEPSNM(KMLOC,JN+1)*PF(IR,JI-1,KMLOC) + ENDIF ENDDO - !write(301,*) 'deriv dy debug 2nd; ',KMLOC,maxval(PNSD(1,:,KMLOC)),maxval(PNSD(2,:,KMLOC)) - !call flush(301) - ENDIF - -!end loop over wavenumber + ENDDO END DO !$ACC END DATA diff --git a/src/trans/gpu/internal/spnsdead_mod.F90 b/src/trans/gpu/internal/spnsdead_mod.F90 deleted file mode 100755 index 0ed2c6dc4..000000000 --- a/src/trans/gpu/internal/spnsdead_mod.F90 +++ /dev/null @@ -1,118 +0,0 @@ -! (C) Copyright 2000- 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 SPNSDEAD_MOD -CONTAINS -SUBROUTINE SPNSDEAD(KM,KF_SCALARS,PEPSNM,PF,PNSD) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -!USE TPM_GEN -USE TPM_DIM ,ONLY : R -USE TPM_FIELDS ,ONLY : F -!USE TPM_TRANS - -!**** *SPNSDEAD* - Compute North-South derivative in spectral space - -! Purpose. -! -------- -! In Laplace space compute the the North-south derivative - -!** Interface. -! ---------- -! CALL SPNSDEAD(...) - -! Explicit arguments : -! -------------------- -! KM -zonal wavenumber (input-c) -! PEPSNM - REPSNM for wavenumber KM (input-c) -! PF (NLEI1,2*KF_SCALARS) - input field (input) -! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) - -! Organisation within NLEI1: -! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) -! overdimensioning -! 1 : n=NSMAX+2 -! 2 : n=NSMAX+1 -! 3 : n=NSMAX -! . : -! . : -! NSMAX+3 : n=0 -! NSMAX+4 : n=-1 - -! Implicit arguments : YOMLAP -! -------------------- - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS -! Temperton, 1991, MWR 119 p1303 - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From SPNSDEAD in IFS CY22R1 - -! ------------------------------------------------------------------ - -IMPLICIT NONE - -INTEGER(KIND=JPIM), INTENT(IN) :: KM -INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS -REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) -REAL(KIND=JPRB), INTENT(INOUT) :: PF(:,:) -REAL(KIND=JPRB), INTENT(IN) :: PNSD(:,:) - -INTEGER(KIND=JPIM) :: IJ, ISKIP, J, JN,JI,ISMAX -REAL(KIND=JPRBT) :: ZEPSNM(-1:R%NSMAX+4) -REAL(KIND=JPRBT) :: ZN(-1:R%NTMAX+4) - -! ------------------------------------------------------------------ - -!* 1. COMPUTE NORTH SOUTH DERIVATIVE. -! ------------------------------- - -!* 1.1 COMPUTE - -ISMAX = R%NSMAX -DO JN=KM-1,ISMAX+2 - IJ = ISMAX+3-JN - ZN(IJ) = F%RN(JN) - IF( JN >= 0 ) ZEPSNM(IJ) = PEPSNM(JN) -ENDDO - -ZN(0) = F%RN(ISMAX+3) -IF(KM == 0) THEN - ISKIP = 2 -ELSE - ISKIP = 1 -ENDIF - -!cdir loopchg -!cdir select(vector) -DO J=1,2*KF_SCALARS,ISKIP - DO JI=2,ISMAX+3-KM - PF(JI+1,J) = PF(JI+1,J)-ZN(JI+1)*ZEPSNM(JI) *PNSD(JI,J) - PF(JI-1,J) = PF(JI-1,J)+ZN(JI-2)*ZEPSNM(JI-1)*PNSD(JI,J) - ENDDO -ENDDO - -! ------------------------------------------------------------------ - -END SUBROUTINE SPNSDEAD -END MODULE SPNSDEAD_MOD diff --git a/src/trans/gpu/internal/sufft_mod.F90 b/src/trans/gpu/internal/sufft_mod.F90 index 8b06ed634..27142dc0c 100755 --- a/src/trans/gpu/internal/sufft_mod.F90 +++ b/src/trans/gpu/internal/sufft_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -18,7 +19,6 @@ SUBROUTINE SUFFT USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TPM_FFT ,ONLY : T - USE TPM_FFTC ,ONLY : TC, INIT_PLANS_FFT #ifdef WITH_FFTW USE TPM_FFTW ,ONLY : TW, INIT_PLANS_FFTW #endif @@ -46,8 +46,6 @@ SUBROUTINE SUFFT ENDIF #endif - CALL INIT_PLANS_FFT(R%NDLON) - ENDIF ! ------------------------------------------------------------------ diff --git a/src/trans/gpu/internal/sump_trans_mod.F90 b/src/trans/gpu/internal/sump_trans_mod.F90 index 2ff268b31..0f43f02ff 100755 --- a/src/trans/gpu/internal/sump_trans_mod.F90 +++ b/src/trans/gpu/internal/sump_trans_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -38,8 +40,7 @@ SUBROUTINE SUMP_TRANS INTEGER(KIND=JPIM) :: JM INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM -INTEGER(KIND=JPIM) :: I1,I2,I3,IAUX0,IAUX1,JA1 -INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF +INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF,OFFSET1,OFFSET2,KMLOC,KM INTEGER(KIND=JPIM),ALLOCATABLE :: IGPTOTL(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZDUM(:) @@ -110,6 +111,19 @@ SUBROUTINE SUMP_TRANS ALLOCATE(D%NPNTGTB1(D%NUMP,R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB1 ',SIZE(D%NPNTGTB1 ),SHAPE(D%NPNTGTB1 ) + ! Global offsets of processors + D%NSTAGT0B(1) = 0 + D%NSTAGT1B(1) = 0 + DO JA=2,NPRTRNS + D%NSTAGT0B(JA) = D%NSTAGT0B(JA-1)+D%NLTSGTB(JA-1) + D%NSTAGT1B(JA) = D%NSTAGT1B(JA-1)+D%NLTSFTB(JA-1) + ENDDO + + ! Global size of foubuf + D%NLENGT0B = D%NSTAGT0B(NPRTRNS)+D%NLTSGTB(NPRTRNS) + D%NLENGT1B = D%NSTAGT1B(NPRTRNS)+D%NLTSFTB(NPRTRNS) + + ! Global offsets of grid points DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(MYSETW) @@ -117,7 +131,7 @@ SUBROUTINE SUMP_TRANS DO JML=D%NPTRMS(JA),D%NPTRMS(JA)+D%NUMPP(JA)-1 IM = D%NALLMS(JML) IF (IM <= G%NMEN(IGL)) THEN - D%NPNTGTB0(IM,JGL) = IPOS + D%NPNTGTB0(IM,JGL) = D%NSTAGT0B(D%NPROCM(IM)) + IPOS IPOS = IPOS+1 ELSE D%NPNTGTB0(IM,JGL) = -99 @@ -133,7 +147,7 @@ SUBROUTINE SUMP_TRANS DO JM=1,D%NUMP IM = D%MYMS(JM) IF (IM <= G%NMEN(IGL)) THEN - D%NPNTGTB1(JM,IGL) = IPOS + D%NPNTGTB1(JM,IGL) = D%NSTAGT1B(D%NPROCL(IGL)) + IPOS IPOS = IPOS+1 ELSE D%NPNTGTB1(JM,IGL) = -99 @@ -141,27 +155,9 @@ SUBROUTINE SUMP_TRANS ENDDO ENDDO ENDDO - - IAUX0 = 0 - IAUX1 = 0 - DO JA=1,NPRTRNS-1 - I1 = MYSENDSET(NPRTRNS,MYSETW,JA) - I2 = MYRECVSET(NPRTRNS,MYSETW,JA) - I3 = -1 - DO JA1=1,NPRTRNS-1 - IF(MYSENDSET(NPRTRNS,MYSETW,JA1) == I2) I3 =MYRECVSET(NPRTRNS,MYSETW,JA1) - ENDDO - IAUX0 = MAX(D%NLTSFTB(I1),D%NLTSGTB(I2),IAUX0) - IAUX1 = MAX(D%NLTSGTB(I2),D%NLTSFTB(I3),IAUX1) - ENDDO - IAUX0 = MAX(D%NLTSGTB(MYSETW),IAUX0) - IAUX1 = MAX(D%NLTSGTB(MYSETW),IAUX1) - DO JA=1,NPRTRNS+1 - D%NSTAGT0B(JA) = (JA-1)*IAUX0 - D%NSTAGT1B(JA) = (JA-1)*IAUX1 - ENDDO - D%NLENGT0B = IAUX0*NPRTRNS - D%NLENGT1B = IAUX1*NPRTRNS + ! D%NSTAGT0B / D%NSTAGT1B: offset of peer rank in send/recv buffer + ! D%NLTSGTB / D%NLTSFTB : size of peer rank in send/recv buffer + ! D%NPNTGTB0 / D%NPNTGTB1: translation inp to global send buffer / recv to out buffer ENDIF ! GRIDPOINT SPACE @@ -253,20 +249,46 @@ SUBROUTINE SUMP_TRANS D%NGPTOTL(:,:) = IGPTOTL(:,:) IF(.NOT.D%LGRIDONLY) THEN - ALLOCATE(D%NSTAGTF(D%NDGL_FS)) + ALLOCATE(D%NSTAGTF(D%NDGL_FS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGTF ',SIZE(D%NSTAGTF ),SHAPE(D%NSTAGTF ) IOFF = 0 DO JGL=1,D%NDGL_FS D%NSTAGTF(JGL) = IOFF IGL = D%NPTRLS(MYSETW) + JGL - 1 - IOFF = IOFF + G%NLOEN(IGL)+3 + ! Each latitude should be able to store NLON real values, or floor(NLON/2)+1 + ! complex values. Note that IOFF should always be even, because we need to + ! store complex values (i.e. 2 floats), but this is the case anyway. + ! WARNING: Extra padding changes results, potentially, though it does not + ! cause wrong results. + IOFF = IOFF + (G%NLOEN(IGL)/2+1)*2 ENDDO + D%NSTAGTF(D%NDGL_FS+1) = IOFF D%NLENGTF = IOFF ENDIF IF(ALLOCATED(ZDUM)) DEALLOCATE(ZDUM) DEALLOCATE(IGPTOTL) +ALLOCATE(D%OFFSETS_GEMM1(D%NUMP+1)) +ALLOCATE(D%OFFSETS_GEMM2(D%NUMP+1)) + +OFFSET1 = 0 +OFFSET2 = 0 +DO KMLOC=1,D%NUMP + KM = D%MYMS(KMLOC) + D%OFFSETS_GEMM1(KMLOC) = OFFSET1 + D%OFFSETS_GEMM2(KMLOC) = OFFSET2 + + !KM=0 is transformed in double precision, no need to store here + IF (KM /= 0) THEN + OFFSET1 = OFFSET1 + ALIGN(G%NDGLU(KM),8) + ! N_OFFSET takes the max of the two GEMMs + OFFSET2 = OFFSET2 + ALIGN((R%NSMAX-KM+3)/2,8) + ENDIF +ENDDO +D%OFFSETS_GEMM1(D%NUMP+1) = OFFSET1 +D%OFFSETS_GEMM2(D%NUMP+1) = OFFSET2 + ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) diff --git a/src/trans/gpu/internal/tpm_dim.F90 b/src/trans/gpu/internal/tpm_dim.F90 index 9cc76b6bc..162c20395 100755 --- a/src/trans/gpu/internal/tpm_dim.F90 +++ b/src/trans/gpu/internal/tpm_dim.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -52,6 +53,5 @@ MODULE TPM_DIM INTEGER(KIND=JPIM) :: R_NTMAX ! Truncation order for tendencies INTEGER(KIND=JPIM) :: R_NDGNH ! Number of rows in northern hemisphere INTEGER(KIND=JPIM) :: R_NDGL ! Number of rows of latitudes -INTEGER(KIND=JPIM) :: R_NNOEXTZL ! Longitude direction END MODULE TPM_DIM diff --git a/src/trans/gpu/internal/tpm_distr.F90 b/src/trans/gpu/internal/tpm_distr.F90 index c196c815f..e72b70560 100755 --- a/src/trans/gpu/internal/tpm_distr.F90 +++ b/src/trans/gpu/internal/tpm_distr.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -159,27 +160,31 @@ MODULE TPM_DISTR REAL(KIND=JPRBT) ,ALLOCATABLE :: RWEIGHT(:) ! Weight per grid-point (if weighted distribution) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPROCA_GP(:) ! Number of grid-points per a-set -INTEGER(KIND=JPIM) :: IADJUST_D -INTEGER(KIND=JPIM) :: IADJUST_I +INTEGER(KIND=JPIM), ALLOCATABLE :: OFFSETS_GEMM1(:), OFFSETS_GEMM2(:) END TYPE DISTR_TYPE !flat versions of the above INTEGER(KIND=JPIM) :: D_NUMP ! No. of spectral waves handled by this processor -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_MYMS(:) ! Wave numbers handled by this PE -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NSTAGT0B(:) ! Start adresses for segments within buffer +INTEGER(KIND=JPIM) ,POINTER :: D_MYMS(:) ! Wave numbers handled by this PE +INTEGER(KIND=JPIM) ,POINTER :: D_NSTAGT0B(:) ! Start adresses for segments within buffer ! (according to processors to whom data ! is going to be sent) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NSTAGT1B(:) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NPROCL(:) ! Process responsible for each lat. (F.S) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NPNTGTB1(:,:) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NASM0(:) ! Address in a spectral array of (m, n=m) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NSTAGTF(:) ! Offset for specific latitude in -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_MSTABF(:) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NPNTGTB0(:,:) -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NPROCM(:) ! Process that does the calc. for certain -INTEGER(KIND=JPIM) ,ALLOCATABLE :: D_NPTRLS(:) ! Pointer to first lat. (F.S) - +INTEGER(KIND=JPIM) ,POINTER :: D_NSTAGT1B(:) +INTEGER(KIND=JPIM) ,POINTER :: D_NPROCL(:) ! Process responsible for each lat. (F.S) +INTEGER(KIND=JPIM) ,POINTER :: D_NPNTGTB1(:,:) +INTEGER(KIND=JPIM) ,POINTER :: D_NASM0(:) ! Address in a spectral array of (m, n=m) +INTEGER(KIND=JPIM) ,POINTER :: D_NSTAGTF(:) ! Offset for specific latitude in +INTEGER(KIND=JPIM) ,POINTER :: D_MSTABF(:) +INTEGER(KIND=JPIM) ,POINTER :: D_NPNTGTB0(:,:) +INTEGER(KIND=JPIM) ,POINTER :: D_NPROCM(:) ! Process that does the calc. for certain +INTEGER(KIND=JPIM) ,POINTER :: D_NPTRLS(:) ! Pointer to first lat. (F.S) + + +! The offsets in the input and output arrays to the gemms. +! (1) are the offsets in the "inputs" of dirtrans ("outputs" invtrans) +! (2) are the offsets in the "outputs" of invtrans ("inputs" dirtrans) +INTEGER(KIND=JPIM), POINTER :: D_OFFSETS_GEMM1(:), D_OFFSETS_GEMM2(:) TYPE(DISTR_TYPE),ALLOCATABLE,TARGET :: DISTR_RESOL(:) TYPE(DISTR_TYPE),POINTER :: D diff --git a/src/trans/gpu/internal/tpm_fftc.F90 b/src/trans/gpu/internal/tpm_fftc.F90 index 662b9477d..949eafdc4 100755 --- a/src/trans/gpu/internal/tpm_fftc.F90 +++ b/src/trans/gpu/internal/tpm_fftc.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2014- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -19,170 +20,159 @@ MODULE TPM_FFTC USE, INTRINSIC :: ISO_C_BINDING -USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT -USE MPL_MODULE, ONLY : MPL_MYRANK - IMPLICIT NONE SAVE PRIVATE -PUBLIC CREATE_PLAN_FFT, DESTROY_PLAN_FFT, DESTROY_ALL_PLANS_FFT, INIT_PLANS_FFT, & - & FFTC_RESOL, TC - -TYPE FFTC_TYPE - INTEGER(KIND=JPIM),POINTER :: N_PLANS(:) - TYPE(FFTC_PLAN),POINTER :: FFTC_PLANS(:) - INTEGER(KIND=JPIM) :: N_MAX=0 - INTEGER(KIND=JPIM) :: N_MAX_PLANS=8 -END TYPE FFTC_TYPE - - -TYPE FFTC_PLAN - INTEGER(KIND=JPIM) :: NPLAN_ID=123456 - INTEGER(KIND=JPIM) :: NPLAN - INTEGER(KIND=JPIM) :: NLOT - INTEGER(KIND=JPIM) :: NTYPE - TYPE(FFTC_PLAN),POINTER :: NEXT_PLAN => NULL() -END TYPE FFTC_PLAN - -TYPE(FFTC_TYPE),ALLOCATABLE,TARGET :: FFTC_RESOL(:) -TYPE(FFTC_TYPE),POINTER :: TC +PUBLIC EXECUTE_DIR_FFT, EXECUTE_INV_FFT + +INTERFACE EXECUTE_DIR_FFT + SUBROUTINE EXECUTE_DIR_FFT_FLOAT(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + USE ISO_C_BINDING + IMPLICIT NONE + REAL(KIND=C_FLOAT), INTENT(IN) :: PREEL_REAL(:) + REAL(KIND=C_FLOAT), INTENT(OUT) :: PREEL_COMPLEX(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + END SUBROUTINE + SUBROUTINE EXECUTE_DIR_FFT_DOUBLE(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + USE ISO_C_BINDING + IMPLICIT NONE + REAL(KIND=C_DOUBLE), INTENT(IN) :: PREEL_REAL(:) + REAL(KIND=C_DOUBLE), INTENT(OUT) :: PREEL_COMPLEX(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + END SUBROUTINE +END INTERFACE +INTERFACE EXECUTE_INV_FFT + SUBROUTINE EXECUTE_INV_FFT_FLOAT(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + USE ISO_C_BINDING + IMPLICIT NONE + REAL(KIND=C_FLOAT), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=C_FLOAT), INTENT(OUT) :: PREEL_REAL(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + END SUBROUTINE + SUBROUTINE EXECUTE_INV_FFT_DOUBLE(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + USE ISO_C_BINDING + IMPLICIT NONE + REAL(KIND=C_DOUBLE), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=C_DOUBLE), INTENT(OUT) :: PREEL_REAL(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + END SUBROUTINE +END INTERFACE ! ------------------------------------------------------------------ CONTAINS ! ------------------------------------------------------------------ - -SUBROUTINE INIT_PLANS_FFT(KDLON) -INTEGER(KIND=JPIM),INTENT(IN) :: KDLON - -TC%N_MAX=KDLON -ALLOCATE(TC%FFTC_PLANS(TC%N_MAX)) -ALLOCATE(TC%N_PLANS(TC%N_MAX)) -TC%N_PLANS(:)=0 -RETURN -END SUBROUTINE INIT_PLANS_FFT - - -SUBROUTINE CREATE_PLAN_FFT(KPLAN,KTYPE,KN,KLOT) -INTEGER(KIND=JPIM),INTENT(OUT) :: KPLAN -INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE,KN,KLOT - -INTEGER(KIND=JPIM) :: IPLAN -INTEGER(KIND=JPIM) :: IRANK, ISTRIDE -INTEGER(KIND=JPIM) :: JL, JN -INTEGER(KIND=JPIM) :: IRDIST,ICDIST,IN(1),IEMBED(1) -LOGICAL :: LLFOUND -LOGICAL :: LLRESTRICT_PLANS=.TRUE. -TYPE(FFTC_PLAN),POINTER :: CURR_FFTC_PLAN,START_FFTC_PLAN -INTERFACE - SUBROUTINE CREATE_PLAN_FFTC(KPLAN,KTYPE,KN,KLOT) BIND(C,NAME="create_plan_fftc_") - USE, INTRINSIC :: ISO_C_BINDING - INTEGER(C_INT) :: KPLAN - INTEGER(C_INT) :: KTYPE,KN,KLOT - END SUBROUTINE CREATE_PLAN_FFTC -END INTERFACE - -IF( KN > TC%N_MAX )THEN - CALL ABOR1('CREATE_PLAN_FFT: KN > N_MAX THAT WAS INITIALISED IN INIT_PLANS_FFTC') -ENDIF - -IRANK=1 -ISTRIDE=1 -IN(1)=KN -IEMBED(1)=IN(1) -ICDIST=KN/2+1 -IRDIST=ICDIST*2 - -!!$OMP CRITICAL -LLFOUND=.FALSE. -IF( TC%FFTC_PLANS(KN)%NPLAN_ID /= 123456 )THEN - WRITE(*,'("CREATE_PLAN_FFT.1: PLAN_ID=",I10)')TC%FFTC_PLANS(KN)%NPLAN_ID - CALL ABOR1('CREATE_PLAN_FFT.1: NPLAN_ID /= 123456') -ENDIF -CURR_FFTC_PLAN=>TC%FFTC_PLANS(KN) -IF( CURR_FFTC_PLAN%NPLAN_ID /= 123456 )THEN - WRITE(*,'("CREATE_PLAN_FFT.2: PLAN_ID=",I10)')CURR_FFTC_PLAN%NPLAN_ID - CALL ABOR1('CREATE_PLAN_FFT.2: NPLAN_ID /= 123456') -ENDIF -! search for plan in existing plans -DO JL=1,TC%N_PLANS(KN) - IF( KLOT == CURR_FFTC_PLAN%NLOT .AND. KTYPE == CURR_FFTC_PLAN%NTYPE )THEN - LLFOUND=.TRUE. - IPLAN=CURR_FFTC_PLAN%NPLAN - EXIT - ELSEIF( JL /= TC%N_PLANS(KN) )THEN - CURR_FFTC_PLAN=>CURR_FFTC_PLAN%NEXT_PLAN - IF( CURR_FFTC_PLAN%NPLAN_ID /= 123456 )THEN - WRITE(*,'("CREATE_PLAN_FFT.3: PLAN_ID=",I10)')CURR_FFTC_PLAN%NPLAN_ID - CALL ABOR1('CREATE_PLAN_FFT.3: NPLAN_ID /= 123456') - ENDIF - ENDIF -ENDDO -IF( .NOT.LLFOUND )THEN - IF( LLRESTRICT_PLANS )THEN - IF( TC%N_PLANS(KN) == TC%N_MAX_PLANS )THEN - ! destroy the plan at the start of the list -! WRITE(*,'("CREATE_PLAN_FFT: BEG: DESTROYING A PLAN AT THE START OF THE LIST")') - CALL DESTROY_PLAN_FFT(TC%FFTC_PLANS(KN)%NPLAN) - TC%FFTC_PLANS(KN)%NPLAN_ID=999999 - START_FFTC_PLAN=>TC%FFTC_PLANS(KN) - TC%FFTC_PLANS(KN)=TC%FFTC_PLANS(KN)%NEXT_PLAN - ! DEALLOCATE(START_FFTC_PLAN) - TC%N_PLANS(KN)=TC%N_PLANS(KN)-1 -! WRITE(*,'("CREATE_PLAN_FFT: END: DESTROYING A PLAN AT THE START OF THE LIST")') - ENDIF - ENDIF - CALL CREATE_PLAN_FFTC(IPLAN,KTYPE,KN,KLOT) - KPLAN=IPLAN - TC%N_PLANS(KN)=TC%N_PLANS(KN)+1 - IF( TC%N_PLANS(KN) /= 1 )THEN - ALLOCATE(CURR_FFTC_PLAN%NEXT_PLAN) - CURR_FFTC_PLAN=>CURR_FFTC_PLAN%NEXT_PLAN - ENDIF - IF( CURR_FFTC_PLAN%NPLAN_ID /= 123456 )THEN - WRITE(*,'("CREATE_PLAN_FFT.4: PLAN_ID=",I10)')CURR_FFTC_PLAN%NPLAN_ID - CALL ABOR1('CREATE_PLAN_FFT.4: NPLAN_ID /= 123456') - ENDIF - CURR_FFTC_PLAN%NPLAN=IPLAN - CURR_FFTC_PLAN%NLOT=KLOT - CURR_FFTC_PLAN%NTYPE=KTYPE - CURR_FFTC_PLAN%NEXT_PLAN=>NULL() -! write(*,'("CREATE_PLAN_FFT: KN=",I5," NPLANS=",I3," KLOT=",I6," KTYPE=",I2,& -! & " NEW IPLAN=",Z16)')KN,TC%N_PLANS(KN),KLOT,KTYPE,IPLAN -ELSE - KPLAN=IPLAN -! write(*,'("CREATE_PLAN_FFT: KN=",I5," NPLANS=",I3," KLOT=",I6," KTYPE=",I2,& -! & " CUR IPLAN=",Z16)')KN,TC%N_PLANS(KN),KLOT,KTYPE,IPLAN -ENDIF -!!$OMP END CRITICAL - -RETURN -END SUBROUTINE CREATE_PLAN_FFT - - -SUBROUTINE DESTROY_PLAN_FFT(KPLAN) -INTEGER(KIND=JPIM),INTENT(IN) :: KPLAN -CALL DESTROY_PLAN_FFTC(KPLAN) -RETURN -END SUBROUTINE DESTROY_PLAN_FFT - - -SUBROUTINE DESTROY_ALL_PLANS_FFT -INTEGER(KIND=JPIM) :: JL, JN -TYPE(FFTC_PLAN),POINTER :: CURR_FFTC_PLAN -DO JN=1,TC%N_MAX - CURR_FFTC_PLAN=>TC%FFTC_PLANS(JN) -ENDDO -WRITE(*,'("DESTROY_ALL_PLANS_FFTC: MPL_RANK=",I6," SUM(TC%N_PLANS(:))=",I10)')& - & MPL_MYRANK(), SUM(TC%N_PLANS(:)) -DEALLOCATE(TC%FFTC_PLANS) -DEALLOCATE(TC%N_PLANS) -RETURN -END SUBROUTINE DESTROY_ALL_PLANS_FFT - +SUBROUTINE EXECUTE_DIR_FFT_FLOAT(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + + IMPLICIT NONE + + REAL(KIND=C_FLOAT), INTENT(IN) :: PREEL_REAL(:) + REAL(KIND=C_FLOAT), INTENT(OUT) :: PREEL_COMPLEX(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTERFACE + SUBROUTINE EXECUTE_DIR_FFT_FLOAT_C(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS,NFFT) BIND(C, name="execute_dir_fft_float") + USE ISO_C_BINDING + REAL(KIND=C_FLOAT), INTENT(IN) :: PREEL_REAL(:) + REAL(KIND=C_FLOAT), INTENT(OUT) :: PREEL_COMPLEX(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD + INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT + END SUBROUTINE + END INTERFACE + + !$ACC HOST_DATA USE_DEVICE(PREEL_REAL,PREEL_COMPLEX) + CALL EXECUTE_DIR_FFT_FLOAT_C(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS,SIZE(LOENS)) + !$ACC END HOST_DATA + +END SUBROUTINE +SUBROUTINE EXECUTE_DIR_FFT_DOUBLE(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + + IMPLICIT NONE + + REAL(KIND=C_DOUBLE), INTENT(IN) :: PREEL_REAL(:) + REAL(KIND=C_DOUBLE), INTENT(OUT) :: PREEL_COMPLEX(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTERFACE + SUBROUTINE EXECUTE_DIR_FFT_DOUBLE_C(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS,NFFT) BIND(C, name="execute_dir_fft_double") + USE ISO_C_BINDING + REAL(KIND=C_DOUBLE), INTENT(IN) :: PREEL_REAL(:) + REAL(KIND=C_DOUBLE), INTENT(OUT) :: PREEL_COMPLEX(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD + INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT + END SUBROUTINE + END INTERFACE + + !$ACC HOST_DATA USE_DEVICE(PREEL_REAL,PREEL_COMPLEX) + CALL EXECUTE_DIR_FFT_DOUBLE_C(PREEL_REAL,PREEL_COMPLEX,KFIELD,LOENS,OFFSETS,SIZE(LOENS)) + !$ACC END HOST_DATA + +END SUBROUTINE + +SUBROUTINE EXECUTE_INV_FFT_FLOAT(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + + IMPLICIT NONE + + REAL(KIND=C_FLOAT), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=C_FLOAT), INTENT(OUT) :: PREEL_REAL(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTERFACE + SUBROUTINE EXECUTE_INV_FFT_FLOAT_C(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS,NFFT) BIND(C, name="execute_inv_fft_float") + USE ISO_C_BINDING + REAL(KIND=C_FLOAT), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=C_FLOAT), INTENT(OUT) :: PREEL_REAL(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD + INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT + END SUBROUTINE + END INTERFACE + + !$ACC HOST_DATA USE_DEVICE(PREEL_COMPLEX,PREEL_REAL) + CALL EXECUTE_INV_FFT_FLOAT_C(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS,SIZE(LOENS)) + !$ACC END HOST_DATA +END SUBROUTINE + +SUBROUTINE EXECUTE_INV_FFT_DOUBLE(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS) + USE PARKIND_ECTRANS ,ONLY : JPIM + + IMPLICIT NONE + + REAL(KIND=C_DOUBLE), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=C_DOUBLE), INTENT(OUT) :: PREEL_REAL(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD + INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTERFACE + SUBROUTINE EXECUTE_INV_FFT_DOUBLE_C(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS,NFFT) BIND(C, name="execute_inv_fft_double") + USE ISO_C_BINDING + REAL(KIND=C_DOUBLE), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=C_DOUBLE), INTENT(OUT) :: PREEL_REAL(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD + INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(:), OFFSETS(:) + INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT + END SUBROUTINE + END INTERFACE + + !$ACC HOST_DATA USE_DEVICE(PREEL_COMPLEX,PREEL_REAL) + CALL EXECUTE_INV_FFT_DOUBLE_C(PREEL_COMPLEX,PREEL_REAL,KFIELD,LOENS,OFFSETS,SIZE(LOENS)) + !$ACC END HOST_DATA +END SUBROUTINE END MODULE TPM_FFTC diff --git a/src/trans/gpu/internal/tpm_fields.F90 b/src/trans/gpu/internal/tpm_fields.F90 index 606e5862f..1492e6e32 100755 --- a/src/trans/gpu/internal/tpm_fields.F90 +++ b/src/trans/gpu/internal/tpm_fields.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -32,7 +33,7 @@ MODULE TPM_FIELDS END TYPE FIELDS_TYPE !flat copies of the above -REAL(KIND=JPRBT) ,ALLOCATABLE :: F_RW(:) ! Weights of the Gaussian quadrature +REAL(KIND=JPRBT) ,POINTER :: F_RW(:) ! Weights of the Gaussian quadrature TYPE(FIELDS_TYPE),ALLOCATABLE,TARGET :: FIELDS_RESOL(:) TYPE(FIELDS_TYPE),POINTER :: F @@ -41,78 +42,11 @@ MODULE TPM_FIELDS REAL(KIND=JPRBT),ALLOCATABLE :: ZAA(:,:,:) !! JPRL for 1/2 REAL(KIND=JPRBT),ALLOCATABLE :: ZAS(:,:,:) !! JPRL for 1/2 - -REAL(KIND=JPRBT), POINTER :: IZBA(:,:,:) !! JPRL for 1/2 -!!origSam REAL(KIND=JPRBT),ALLOCATABLE,TARGET :: IZBS(:,:,:) !! JPRL for 1/2 -REAL(KIND=JPRBT),ALLOCATABLE :: IZBS(:) !! from working RAPS -REAL(KIND=JPRBT),ALLOCATABLE :: IZCA(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: IZCS(:,:,:) -!REAL(KIND=JPRBT),ALLOCATABLE :: IZCAT(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: IZCST(:) - -REAL(KIND=JPRBT),ALLOCATABLE :: DZBA(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: DZBS(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: DZBAT(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: DZBST(:) !! JPRL for 1/2 -REAL(KIND=JPRBT),ALLOCATABLE :: DZCA(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: DZCS(:,:,:) -!REAL(KIND=JPRBT),POINTER :: DZCAT(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: DZCAT(:) -REAL(KIND=JPRBT),ALLOCATABLE,TARGET :: DZCST(:) - -! Arrays used for rescaling to allow half-precision Legende transforms -REAL(KIND=JPRBT), ALLOCATABLE :: ZAMAX(:,:) -REAL(KIND=JPRBT), ALLOCATABLE :: ZSMAX(:,:) - ! for m=0 in ledir_mod: REAL(KIND=JPRD),ALLOCATABLE :: ZAA0(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAS0(:,:) -REAL(KIND=JPRD),ALLOCATABLE :: DZBST0(:) -REAL(KIND=JPRD),ALLOCATABLE :: DZCAT0(:) -REAL(KIND=JPRD),ALLOCATABLE :: DZCST0(:) INTEGER(KIND=JPIM) :: KMLOC0 -INTEGER(KIND=JPIM) :: LDZAA -INTEGER(KIND=JPIM) :: LDZAS -INTEGER(KIND=JPIM) :: TDZAA -INTEGER(KIND=JPIM) :: TDZAS - -INTEGER(KIND=JPIM) :: ILDZBA -INTEGER(KIND=JPIM) :: ILDZBS -INTEGER(KIND=JPIM) :: ILDZCA -INTEGER(KIND=JPIM) :: ILDZCS - - - -INTEGER(KIND=JPIM) :: DLDZBA -INTEGER(KIND=JPIM) :: DLDZBS -INTEGER(KIND=JPIM) :: DLDZCA -INTEGER(KIND=JPIM) :: DLDZCS - -! enable calling setup_trans with a different set of fields than inv_trans and dir_trans: -! IF_FS_INV0: size used for the allocation in setup_trans -! IF_FS_INV: size used in inv_trans and dir_Trans, needs to be <= IF_FS_INV0 -INTEGER(KIND=JPIM) :: IF_FS_INV, IF_FS_INV0 -INTEGER(KIND=JPIM) :: IF_FS_DIR, IF_FS_DIR0 -INTEGER(KIND=JPIM) :: NFLEV, NFLEV0 -INTEGER(KIND=JPIM) :: ITDZBA, ITDZBA0 -INTEGER(KIND=JPIM) :: ITDZBS, ITDZBS0 -INTEGER(KIND=JPIM) :: DTDZBA, DTDZBA0 -INTEGER(KIND=JPIM) :: DTDZBS, DTDZBS0 -INTEGER(KIND=JPIM) :: DTDZCA, DTDZCA0 -INTEGER(KIND=JPIM) :: DTDZCS, DTDZCS0 -INTEGER(KIND=JPIM) :: ITDZCA, ITDZCA0 -INTEGER(KIND=JPIM) :: ITDZCS, ITDZCS0 - -REAL(KIND=JPRB),ALLOCATABLE, TARGET :: ZIA(:,:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZEPSNM(:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZSOA1(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZAOA1(:,:,:) -INTEGER(KIND=JPIM),ALLOCATABLE :: ISTAN(:,:) -INTEGER(KIND=JPIM),ALLOCATABLE :: ISTAS(:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZSIA(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZAIA(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE, TARGET :: ZOA1(:,:,:) -REAL(KIND=JPRBT),ALLOCATABLE, TARGET :: ZOA2(:,:,:) END MODULE TPM_FIELDS diff --git a/src/trans/gpu/internal/tpm_geometry.F90 b/src/trans/gpu/internal/tpm_geometry.F90 index 21ce925bd..c2738c6a4 100755 --- a/src/trans/gpu/internal/tpm_geometry.F90 +++ b/src/trans/gpu/internal/tpm_geometry.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -31,10 +32,10 @@ MODULE TPM_GEOMETRY END TYPE GEOM_TYPE !flat copies of the above -INTEGER(KIND=JPIM),ALLOCATABLE :: G_NDGLU(:) ! NUMBER OF HEMISPERIC LATITUDES -INTEGER(KIND=JPIM),ALLOCATABLE :: G_NMEN(:) ! ASSOCIATED CUT-OFF WAVE NUMBER +INTEGER(KIND=JPIM),POINTER :: G_NDGLU(:) ! NUMBER OF HEMISPERIC LATITUDES +INTEGER(KIND=JPIM),POINTER :: G_NMEN(:) ! ASSOCIATED CUT-OFF WAVE NUMBER INTEGER(KIND=JPIM) :: G_NMEN_MAX -INTEGER(KIND=JPIM),ALLOCATABLE :: G_NLOEN(:) ! NUMBER OF POINTS ON A PARALLEL +INTEGER(KIND=JPIM),POINTER :: G_NLOEN(:) ! NUMBER OF POINTS ON A PARALLEL INTEGER(KIND=JPIM) :: G_NLOEN_MAX TYPE(GEOM_TYPE),ALLOCATABLE,TARGET :: GEOM_RESOL(:) diff --git a/src/trans/gpu/internal/tpm_stats.F90 b/src/trans/gpu/internal/tpm_stats.F90 new file mode 100644 index 000000000..27c6dcfa8 --- /dev/null +++ b/src/trans/gpu/internal/tpm_stats.F90 @@ -0,0 +1,61 @@ +! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 TPM_STATS + +IMPLICIT NONE + +CHARACTER(LEN=32) :: DESCRIPTIONS(100) + +CONTAINS + +SUBROUTINE GSTATS_LABEL_NVTX(KNUM,CTYPE,CDESC) +USE EC_PARKIND ,ONLY : JPIM +IMPLICIT NONE +INTEGER(KIND=JPIM) :: KNUM +CHARACTER(*) CDESC +CHARACTER(*) CTYPE + +IF (KNUM >= 400 .AND. KNUM < 500) THEN + DESCRIPTIONS(KNUM-400+1) = CDESC +ENDIF +CALL GSTATS_LABEL(KNUM,CTYPE,CDESC) +END SUBROUTINE + +SUBROUTINE GSTATS_NVTX(KNUM,KSWITCH) + USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT + USE NVTX + + IMPLICIT NONE + + INTEGER(KIND=JPIM),INTENT(IN) :: KNUM + INTEGER(KIND=JPIM),INTENT(IN) :: KSWITCH + INTEGER(KIND=JPIM) :: ICOLOR + + IF (KNUM >= 400 .AND. KNUM < 500) THEN + IF (KSWITCH == 0) THEN + ICOLOR=0 + IF (KNUM>=430) ICOLOR=10 !LB markers + IF (KNUM==410) ICOLOR=13 !DIR COMPLETE + IF (KNUM==420) ICOLOR=14 !INV COMPLETE + IF (ICOLOR /= 0) THEN + CALL NVTXSTARTRANGE(DESCRIPTIONS(KNUM-400+1),ICOLOR) + ELSE + CALL NVTXSTARTRANGE(DESCRIPTIONS(KNUM-400+1)) + ENDIF + ELSEIF (KSWITCH == 1) THEN + CALL NVTXENDRANGE() + ENDIF + ENDIF + CALL GSTATS(KNUM,KSWITCH) +END SUBROUTINE GSTATS_NVTX + +END MODULE TPM_STATS + diff --git a/src/trans/gpu/internal/tpm_trans.F90 b/src/trans/gpu/internal/tpm_trans.F90 index 6010612c2..8b72deae9 100755 --- a/src/trans/gpu/internal/tpm_trans.F90 +++ b/src/trans/gpu/internal/tpm_trans.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -13,6 +14,7 @@ MODULE TPM_TRANS ! USE PARKIND_ECTRANS ,ONLY : JPIM, JPRBT +USE ISO_C_BINDING, ONLY: C_INT8_T IMPLICIT NONE @@ -54,12 +56,12 @@ MODULE TPM_TRANS LOGICAL :: LGPNORM = .FALSE. ! indicates whether transform is being done for gpnorm -REAL(KIND=JPRBT),ALLOCATABLE,TARGET :: ZGTF(:,:) - -REAL(KIND=JPRBT),ALLOCATABLE :: ZAVE(:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGL(:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGL(:,:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGPN(:) -REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGPN(:) +! This is used in fourier space and in spectral space. It's reused among +! the transforms because we cannot reallocate - the captured CUDA graphs +! should not be modified. Hence, we keep it if it is large enough, otherwise +! we adapt the size. After 2 iterations this should lead to constant runtimes +! (the first iteration is used to get the max buffer size, the second iteration +! is going to recreate the graphs if needed) +INTEGER(KIND=C_INT8_T),POINTER :: REUSE_PTR(:) END MODULE TPM_TRANS diff --git a/src/trans/gpu/internal/trgtol_mod.F90 b/src/trans/gpu/internal/trgtol_mod.F90 index 17cdce08e..6ed2a3273 100755 --- a/src/trans/gpu/internal/trgtol_mod.F90 +++ b/src/trans/gpu/internal/trgtol_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1995- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,1366 +10,618 @@ ! MODULE TRGTOL_MOD - CONTAINS - SUBROUTINE TRGTOL_CUDAAWARE(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) - - !**** *TRGTOL * - transposition of grid point data from column - ! structure to latitudinal. Reorganize data between - ! grid point calculations and direct Fourier Transform - - ! Version using CUDA-aware MPI - - ! Purpose. - ! -------- - - - !** Interface. - ! ---------- - ! *call* *trgtol(...) - - ! Explicit arguments : - ! -------------------- - ! PGLAT - Latitudinal data ready for direct FFT (output) - ! PGP - Blocked grid point data (input) - - ! Implicit arguments : - ! -------------------- - - ! Method. - ! ------- - ! See documentation - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! MPP Group *ECMWF* - - ! Modifications. - ! -------------- - ! Original: 95-10-01 - ! D.Dent : 97-08-04 Reorganisation to allow - ! NPRTRV to differ from NPRGPEW - ! : 98-06-17 add mailbox control logic (from TRLTOM) - ! =99-03-29= Mats Hamrud and Deborah Salmond - ! JUMP in FFT's changed to 1 - ! KINDEX introduced and ZCOMBUF not used for same PE - ! 01-11-23 Deborah Salmond and John Hague - ! LIMP_NOOLAP Option for non-overlapping message passing - ! and buffer packing - ! 01-12-18 Peter Towers - ! Improved vector performance of GTOL_PACK,GTOL_UNPACK - ! 03-04-02 G. Radnoti: call barrier always when nproc>1 - ! 08-01-01 G.Mozdzynski: cleanup - ! 09-01-02 G.Mozdzynski: use non-blocking recv and send - ! ------------------------------------------------------------------ - - - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_BARRIER - - USE TPM_GEN ,ONLY : NOUT, LSYNC_TRANS - USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRNS, MTAGGL, & - & MYSETV, MYSETW, MYPROC, NPROC - USE TPM_TRANS ,ONLY : LDIVGP, LGPNORM, LSCDERS, LUVDER, LVORGP, NGPBLKS - - USE INIGPTR_MOD ,ONLY : INIGPTR - USE PE2SET_MOD ,ONLY : PE2SET - !USE MYSENDSET_MOD - USE MPL_DATA_MODULE, only: MPL_COMM_OML - USE OML_MOD, only: OML_MY_THREAD - !USE MYRECVSET_MOD - USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS - ! - USE MPI - + USE ALLOCATOR_MOD IMPLICIT NONE - - REAL(KIND=JPRBT),INTENT(OUT) :: PGLAT(:,:) - INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(:) - INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP - INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G - INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) - - REAL(KIND=JPRBT),ALLOCATABLE :: ZCOMBUFS(:,:),ZCOMBUFR(:,:) - INTEGER(KIND=JPIM) :: ICOMBUFS_FLD(NPROC),ICOMBUFR_FLD(NPROC) - REAL(KIND=JPRBT) :: ZDUM(2) - - INTEGER(KIND=JPIM) :: ISENT (NPROC) - INTEGER(KIND=JPIM) :: IRCVD (NPROC) - INTEGER(KIND=JPIM) :: ISENDTOT (NPROC) - INTEGER(KIND=JPIM) :: IRECVTOT (NPROC) - INTEGER(KIND=JPIM) :: IREQ (NPROC*4) - INTEGER(KIND=JPIM) :: JRECV (NPROC) - INTEGER(KIND=JPIM) :: JSEND (NPROC) - - ! LOCAL INTEGER SCALARS - INTEGER(KIND=JPIM) :: IFIRST, IFIRSTLAT, IGL, IGLL, ILAST,& - &ILASTLAT, ILEN, JROC, IPOS, ISETA, & - &ISETB, IRECV, IRECVSET, & - &ISETV, ISEND, ISENDSET, ITAG, J, JBLK, JFLD, & - &JGL, JK, JL, JLOOP, ISETW, IFLD, & - &II,INDOFFX,IBUFLENS,IBUFLENR,INRECV, IPROC,IFLDS, & - &INSEND,INS,INR,IR, IUNIT, JKL, JK_MAX - - ! LOCAL LOGICAL SCALARS - LOGICAL :: LLPGPUV,LLPGP3A,LLPGP3B,LLPGP2,LLPGPONLY - LOGICAL :: LLUV(KF_GP),LLGP2(KF_GP),LLGP3A(KF_GP),LLGP3B(KF_GP) - LOGICAL :: LLDONE, LLINDER - INTEGER(KIND=JPIM) :: IUVLEVS(KF_GP),IUVPARS(KF_GP),IGP2PARS(KF_GP) - INTEGER(KIND=JPIM) :: IGP3APARS(KF_GP),IGP3ALEVS(KF_GP),IGP3BPARS(KF_GP),IGP3BLEVS(KF_GP) - INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF - INTEGER(KIND=JPIM) :: IOFF,IOFF1,IOFFNS,IOFFEW,J1,J2 - INTEGER(KIND=JPIM) :: KINDEX(D%NLENGTF),INDOFF(NPROC),IFLDOFF(MAX(KF_GP,KF_FS)) - INTEGER(KIND=JPIM) :: ISEND_FLD_TOTAL(NPROC),ISEND_FLD_END - INTEGER(KIND=JPIM) :: IRECV_FLD_END - INTEGER(KIND=JPIM) :: INUMFLDS - INTEGER(KIND=JPIM) :: IGPTRSEND(2,NGPBLKS,NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTRRECV(NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTROFF(NGPBLKS) - ! INTEGER FUNCTIONS - INTEGER(KIND=JPIM) :: IRECVCOUNT,ISENDCOUNT - INTEGER(KIND=JPIM) :: IJPOS(NGPBLKS),IFLDA(KF_GP),JJ,JI,IFLDT - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR - - INTEGER(KIND=JPIM) :: IERROR, irank - - REAL(KIND=JPRBT) :: TIMEF, tc - - #ifdef PARKINDTRANS_SINGLE - #define TRGTOL_DTYPE MPI_REAL - #else - #define TRGTOL_DTYPE MPI_DOUBLE_PRECISION - #endif - - ! ------------------------------------------------------------------ - - !* 0. Some initializations - ! -------------------- - - IF (LHOOK) CALL DR_HOOK('TRGTOL_CUDAAWARE',0,ZHOOK_HANDLE) - - iunit=300+myproc - - CALL GSTATS(1805,0) - - LLINDER = .FALSE. - LLPGPUV = .FALSE. - LLPGP3A = .FALSE. - LLPGP3B = .FALSE. - LLPGP2 = .FALSE. - LLPGPONLY = .FALSE. - IF(PRESENT(KPTRGP)) LLINDER = .TRUE. - IF(PRESENT(PGP)) LLPGPONLY = .TRUE. - IF(PRESENT(PGPUV)) LLPGPUV = .TRUE. - IF(PRESENT(PGP3A)) LLPGP3A = .TRUE. - IF(PRESENT(PGP3B)) LLPGP3B = .TRUE. - IF(PRESENT(PGP2)) LLPGP2 = .TRUE. - IUVPAR=0 - IUVLEV=0 - IOFF1=0 - IOFFNS=KF_SCALARS_G - IOFFEW=2*KF_SCALARS_G - LLUV(:) = .FALSE. - IUVPARS(:) = -99 - IUVLEVS(:) = -99 - IF (LLPGPUV) THEN + + PRIVATE + PUBLIC :: TRGTOL_HANDLE, TRGTOL, PREPARE_TRGTOL + + TYPE TRGTOL_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HCOMBUFS, HCOMBUFR_AND_REEL + END TYPE +CONTAINS + FUNCTION PREPARE_TRGTOL(ALLOCATOR,KF_GP,KF_FS) RESULT(HTRGTOL) + USE PARKIND_ECTRANS, ONLY : JPIM, JPRB, JPRBT + USE ALLOCATOR_MOD + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP, KF_FS + TYPE(TRGTOL_HANDLE) :: HTRGTOL + + REAL(KIND=JPRBT) :: DUMMY + + INTEGER(KIND=C_SIZE_T) :: NELEM + + HTRGTOL%HCOMBUFS = RESERVE(ALLOCATOR, KF_GP*D%NGPTOT*SIZEOF(DUMMY)) + + NELEM = KF_FS*D%NLENGTF*SIZEOF(DUMMY) ! ZCOMBUFR + NELEM = NELEM + KF_FS*D%NLENGTF*SIZEOF(DUMMY) ! PREEL_REAL + HTRGTOL%HCOMBUFR_AND_REEL = RESERVE(ALLOCATOR, NELEM) + END FUNCTION + + SUBROUTINE TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& + &PGP,PGPUV,PGP3A,PGP3B,PGP2,KPTRGP,KVSETUV,KVSETSC,KVSETSC3A,KVSETSC3B,KVSETSC2) + + !**** *TRGTOL * - transposition of grid point data from column + ! structure to latitudinal. Reorganize data between + ! grid point calculations and direct Fourier Transform + + ! Version using CUDA-aware MPI + + ! Purpose. + ! -------- + + + !** Interface. + ! ---------- + ! *call* *trgtol(...) + + ! Explicit arguments : + ! -------------------- + ! PREEL_REAL - Latitudinal data ready for direct FFT (output) + ! PGP - Blocked grid point data (input) + + ! Implicit arguments : + ! -------------------- + + ! Method. + ! ------- + ! See documentation + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! MPP Group *ECMWF* + + ! Modifications. + ! -------------- + ! Original: 95-10-01 + ! D.Dent : 97-08-04 Reorganisation to allow + ! NPRTRV to differ from NPRGPEW + ! : 98-06-17 add mailbox control logic (from TRLTOM) + ! =99-03-29= Mats Hamrud and Deborah Salmond + ! JUMP in FFT's changed to 1 + ! KINDEX introduced and ZCOMBUF not used for same PE + ! 01-11-23 Deborah Salmond and John Hague + ! LIMP_NOOLAP Option for non-overlapping message passing + ! and buffer packing + ! 01-12-18 Peter Towers + ! Improved vector performance of GTOL_PACK,GTOL_UNPACK + ! 03-04-02 G. Radnoti: call barrier always when nproc>1 + ! 08-01-01 G.Mozdzynski: cleanup + ! 09-01-02 G.Mozdzynski: use non-blocking recv and send + ! ------------------------------------------------------------------ + + + + USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB , JPRBT + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE MPL_MODULE ,ONLY : MPL_WAIT, MPL_BARRIER + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS + USE TPM_DISTR ,ONLY : D,MYSETV, MYSETW, MTAGLG,NPRCIDS,MYPROC,NPROC,NPRTRW,NPRTRV + USE PE2SET_MOD ,ONLY : PE2SET + USE MPL_DATA_MODULE ,ONLY : MPL_COMM_OML + USE OML_MOD ,ONLY : OML_MY_THREAD + USE MPI + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + USE TPM_TRANS ,ONLY : NPROMA + USE ALLOCATOR_MOD + USE OPENACC_EXT + + IMPLICIT NONE + + REAL(KIND=JPRBT),INTENT(OUT), POINTER :: PREEL_REAL(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:), KVSETSC(:), KVSETSC3A(:), KVSETSC3B(:), KVSETSC2(:) + REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:), PGPUV(:,:,:,:), PGP3A(:,:,:,:), PGP3B(:,:,:,:), PGP2(:,:,:) + + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRGTOL_HANDLE), INTENT(IN) :: HTRGTOL + + ! LOCAL VARIABLES + + ! LOCAL INTEGER SCALARS + REAL(KIND=JPRBT), POINTER :: ZCOMBUFS(:),ZCOMBUFR(:) + + INTEGER(KIND=JPIM) :: ISENDTOT (NPROC) + INTEGER(KIND=JPIM) :: IRECVTOT (NPROC) + INTEGER(KIND=JPIM) :: IREQ (NPROC*2) + INTEGER(KIND=JPIM) :: IRECV_TO_PROC(NPROC) + INTEGER(KIND=JPIM) :: ISEND_TO_PROC(NPROC) + + INTEGER(KIND=JPIM) :: IFIRSTLAT, IGL, IGLL, ILAST,& + &ILASTLAT, ILEN, JROC, IPOS, ISETA, & + &ISETB, IRECV, & + &ISETV, ISEND, JBLK, JFLD, & + &JGL, JI, JK, JL, ISETW, IFLD, & + &II,IBUFLENR,IRECV_COUNTS, IPROC,IFLDS, & + &ISEND_COUNTS,INS,INR,IR, JKL, PBOUND, IERROR, ILOCAL_LAT + INTEGER(KIND=JPIM) :: KF, KGL, KI, J3 + + INTEGER(KIND=JPIM) :: IOFF, ILAT_STRIP + INTEGER(KIND=JPIM) :: IRECV_BUFR_TO_OUT(D%NLENGTF,2),IRECV_BUFR_TO_OUT_OFFSET(NPROC), IRECV_BUFR_TO_OUT_V + INTEGER(KIND=JPIM) :: ISEND_FIELD_COUNT(NPRTRV),ISEND_FIELD_COUNT_V + INTEGER(KIND=JPIM) :: ISEND_WSET_SIZE(NPRTRW),ISEND_WSET_SIZE_V + INTEGER(KIND=JPIM) :: ISEND_WSET_OFFSET(NPRTRW+1), ISEND_WSET_OFFSET_V + INTEGER(KIND=JPIM), ALLOCATABLE :: ICOMBUFS_OFFSET(:),ICOMBUFR_OFFSET(:) + INTEGER(KIND=JPIM) :: ICOMBUFS_OFFSET_V, ICOMBUFR_OFFSET_V + INTEGER(KIND=JPIM) :: IFLDA(KF_GP) + INTEGER(KIND=JPIM) :: IVSET(KF_GP) + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + INTEGER(JPIM), PARAMETER :: PGP_INDICES_UV = 1 + INTEGER(JPIM), PARAMETER :: PGP_INDICES_GP2 = 2 + INTEGER(JPIM), PARAMETER :: PGP_INDICES_GP3A = 3 + INTEGER(JPIM), PARAMETER :: PGP_INDICES_GP3B = 4 + INTEGER(JPIM), PARAMETER :: PGP_INDICES_END = 5 + INTEGER(JPIM) :: PGP_INDICES(PGP_INDICES_END) + + TYPE(EXT_ACC_ARR_DESC) :: ACC_POINTERS(5) ! at most 5 copyins... + INTEGER(KIND=JPIM) :: ACC_POINTERS_CNT = 0 + + #ifdef PARKINDTRANS_SINGLE + #define TRGTOL_DTYPE MPI_REAL + #else + #define TRGTOL_DTYPE MPI_DOUBLE_PRECISION + #endif + + ! ------------------------------------------------------------------ + + !* 0. Some initializations + ! -------------------- + ! Note we have either + ! - KVSETUV and KVSETSC (with PGP, which has u, v, and scalar fields), or + ! - KVSETUV, KVSETSC2, KVSETSC3A KVSETSC3B (with PGPUV, GP3A, PGP3B and PGP2) + ! KVSETs are optionals. Their sizes canalso be inferred from KV_UV_G/KV_SCALARS_G (which + ! should match PSPXXX and PGPXXX arrays) IOFF=0 - IUVLEV=UBOUND(PGPUV,2) - IF(LVORGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV + IF(PRESENT(KVSETUV)) THEN + IVSET(IOFF+1:IOFF+KF_UV_G) = KVSETUV(:) + IOFF=IOFF+KF_UV_G + IVSET(IOFF+1:IOFF+KF_UV_G) = KVSETUV(:) + IOFF=IOFF+KF_UV_G + ELSE + IVSET(IOFF+1:IOFF+KF_UV_G) = -1 + IOFF=IOFF+KF_UV_G + IVSET(IOFF+1:IOFF+KF_UV_G) = -1 + IOFF=IOFF+KF_UV_G ENDIF - IF(LDIVGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV + IF(PRESENT(KVSETSC)) THEN + IVSET(IOFF+1:IOFF+KF_SCALARS_G) = KVSETSC(:) + IOFF=IOFF+KF_SCALARS_G + ELSE + IF(PRESENT(KVSETSC2)) THEN + IVSET(IOFF+1:IOFF+SIZE(KVSETSC2)) = KVSETSC2(:) + IOFF=IOFF+SIZE(KVSETSC2) + ENDIF + IF(PRESENT(KVSETSC3A)) THEN + DO J3=1,SIZE(PGP3A,3) + IVSET(IOFF+1:IOFF+SIZE(KVSETSC3A))=KVSETSC3A(:) + IOFF=IOFF+SIZE(KVSETSC3A) + ENDDO + ENDIF + IF(PRESENT(KVSETSC3B)) THEN + DO J3=1,SIZE(PGP3B,3) + IVSET(IOFF+1:IOFF+SIZE(KVSETSC3B))=KVSETSC3B(:) + IOFF=IOFF+SIZE(KVSETSC3B) + ENDDO + ENDIF ENDIF - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - ENDDO - IUVPAR=IUVPAR+2 - LLUV(IOFF+1:IOFF+2*IUVLEV)=.TRUE. - IOFF=IOFF+2*IUVLEV - IOFF1=IOFF - IOFFNS=IOFFNS+IOFF - IOFFEW=IOFFEW+IOFF - IOFF=IUVPAR*IUVLEV+KF_SCALARS_G - IF(LUVDER) THEN - IF(LSCDERS) IOFF=IOFF+KF_SCALARS_G - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - LLUV(IOFF+J)=.TRUE. - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - LLUV(IOFF+J+IUVLEV)=.TRUE. - ENDDO - IUVPAR=IUVPAR+2 - IOFF=IOFF+2*IUVLEV - IOFFEW=IOFFEW+2*IUVLEV + + IF (IOFF /= 2*KF_UV_G+KF_SCALARS_G) THEN + PRINT*, "TRGTOL: ERROR IN IVSET COMPUTATION" + FLUSH(6) + STOP 38 ENDIF - ENDIF - LLGP2(:)=.FALSE. - IF(LLPGP2) THEN - IOFF=IOFF1 - IGP2PAR=UBOUND(PGP2,2) - IF(LSCDERS) IGP2PAR=IGP2PAR/3 - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J - ENDDO - IOFF1=IOFF1+IGP2PAR - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+IGP2PAR - ENDDO - IOFFNS=IOFF+IGP2PAR - IOFF=IOFFEW - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+2*IGP2PAR + + IF (LHOOK) CALL DR_HOOK('TRGTOL',0,ZHOOK_HANDLE) + + CALL GSTATS(1805,0) + IOFF=1 + PGP_INDICES(PGP_INDICES_UV) = IOFF + IF (PRESENT(PGPUV)) IOFF=IOFF+UBOUND(PGPUV,2)*2 + PGP_INDICES(PGP_INDICES_GP2) = IOFF + IF (PRESENT(PGP2)) IOFF=IOFF+UBOUND(PGP2,2) + PGP_INDICES(PGP_INDICES_GP3A) = IOFF + IF (PRESENT(PGP3A)) IOFF=IOFF+UBOUND(PGP3A,2)*UBOUND(PGP3A,3) + PGP_INDICES(PGP_INDICES_GP3B) = IOFF + IF (PRESENT(PGP3B)) IOFF=IOFF+UBOUND(PGP3B,2)*UBOUND(PGP3B,3) + PGP_INDICES(PGP_INDICES_END) = IOFF + + ! Prepare sender arrays + ! find number of fields on a certain V-set + IF(NPRTRV == 1) THEN + ! This is needed because IVSET(JFLD) == -1 if there is only one V-set + ISEND_FIELD_COUNT(1) = KF_GP + ELSE + ISEND_FIELD_COUNT(:) = 0 + DO JFLD=1,KF_GP + ISEND_FIELD_COUNT(IVSET(JFLD)) = ISEND_FIELD_COUNT(IVSET(JFLD)) + 1 ENDDO - IOFFEW=IOFF+IGP2PAR ENDIF - ENDIF - LLGP3A(:) = .FALSE. - IF(LLPGP3A) THEN - IGP3ALEV=UBOUND(PGP3A,2) - IGP3APAR=UBOUND(PGP3A,3) - IF(LSCDERS) IGP3APAR=IGP3APAR/3 - IOFF=IOFF1 - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1 - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO + ! find number of grid-points on a certain W-set that overlap with myself + ISEND_WSET_SIZE(:) = 0 + DO ILOCAL_LAT=D%NFRSTLAT(MY_REGION_NS),D%NLSTLAT(MY_REGION_NS) + ILAT_STRIP = ILOCAL_LAT-D%NFRSTLAT(MY_REGION_NS)+D%NPTRFLOFF+1 + ISEND_WSET_SIZE(D%NPROCL(ILOCAL_LAT)) = & + & ISEND_WSET_SIZE(D%NPROCL(ILOCAL_LAT))+D%NONL(ILAT_STRIP,MY_REGION_EW) ENDDO - IPAROFF=IGP3APAR - IOFF1=IOFF1+IGP3APAR*IGP3ALEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3APAR - IOFFNS=IOFFNS+IGP3APAR*IGP3ALEV - IOFF=IOFFEW - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IOFFEW=IOFFEW+IGP3APAR*IGP3ALEV - ENDIF - ENDIF - LLGP3B(:) = .FALSE. - IF(LLPGP3B) THEN - IGP3BLEV=UBOUND(PGP3B,2) - IGP3BPAR=UBOUND(PGP3B,3) - IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 - IOFF=IOFF1 - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1 - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO + ! sum up offsets + ISEND_WSET_OFFSET(1) = 0 + DO JROC=1,NPRTRW + ISEND_WSET_OFFSET(JROC+1)=ISEND_WSET_OFFSET(JROC)+ISEND_WSET_SIZE(JROC) ENDDO - IPAROFF=IGP3BPAR - IOFF1=IOFF1+IGP3BPAR*IGP3BLEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3BPAR - IOFFNS=IOFFNS+IGP3BPAR*IGP3BLEV - IOFF=IOFFEW - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IOFFEW=IOFFEW+IGP3BPAR*IGP3BLEV - ENDIF - ENDIF - - - CALL INIGPTR(IGPTRSEND,IGPTRRECV) - LLDONE = .FALSE. - - !$ACC DATA COPYIN(LLGP2,LLGP3A,LLGP3B,LLUV,IGPTRSEND) - - ITAG = MTAGGL - - INDOFFX = 0 - IBUFLENS = 0 - IBUFLENR = 0 - INRECV = 0 - INSEND = 0 - - DO JROC=1,NPROC - - CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) - IRECVSET = ISETA - ISEND = JROC - ISENDSET = ISETV - ISENT(JROC) = 0 - IRCVD(JROC) = 0 - - ! count up expected number of fields - IPOS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == ISENDSET .OR. KVSET(JFLD) == -1) IPOS = IPOS+1 + DO JROC=1,NPROC + CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) + ! total send size is # points per field * # fields + ISENDTOT(JROC) = ISEND_WSET_SIZE(ISETW)*ISEND_FIELD_COUNT(ISETV) ENDDO - ISEND_FLD_TOTAL(JROC) = IPOS - ISENDTOT(JROC) = IGPTRRECV(ISETW)*IPOS - - IF( JROC /= MYPROC) THEN - IBUFLENS = MAX(IBUFLENS,ISENDTOT(JROC)) - IF(ISENDTOT(JROC) > 0) THEN - INSEND = INSEND+1 - JSEND(INSEND)=JROC + + ! Prepare receiver arrays + IRECV_BUFR_TO_OUT_OFFSET(:) = 0 + DO JROC=1,NPROC + ! Get new offset to my current KINDEX entry + IF (JROC > 1 .AND. KF_FS > 0) THEN + IRECV_BUFR_TO_OUT_OFFSET(JROC) = IRECV_BUFR_TO_OUT_OFFSET(JROC-1)+IRECVTOT(JROC-1)/KF_FS + ELSEIF (JROC > 1) THEN + IRECV_BUFR_TO_OUT_OFFSET(JROC) = IRECV_BUFR_TO_OUT_OFFSET(JROC-1) ENDIF - ENDIF - - IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(IRECVSET)) - ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(IRECVSET)) - - IPOS = 0 - DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(IRECVSET)+JGL-D%NFRSTLAT(IRECVSET) - IPOS = IPOS+D%NONL(IGL,ISETB) - ENDDO - - IRECVTOT(JROC) = IPOS*KF_FS - - IF(IRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN - INRECV = INRECV + 1 - JRECV(INRECV)=JROC - ENDIF - - IF( JROC /= MYPROC) IBUFLENR = MAX(IBUFLENR,IRECVTOT(JROC)) - - IF(IPOS > 0) THEN - INDOFF(JROC) = INDOFFX - INDOFFX = INDOFFX+IPOS + + CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) + + ! MAX(Index of first fourier latitude for this W set, first latitude of a senders A set) + ! i.e. we find the overlap between what we have on sender side (others A set) and the receiver + ! (me, the W-set). Ideally those conincide, at least mostly. + IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) + ! MIN(Index of last fourier latitude for this W set, last latitude of a senders A set) + ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) + IPOS = 0 DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(IRECVSET)+JGL-D%NFRSTLAT(IRECVSET) + ! get from "actual" latitude to the latitude strip offset + IGL = JGL-D%NFRSTLAT(ISETA)+D%NPTRFRSTLAT(ISETA) + ! get from "actual" latitude to the latitude offset IGLL = JGL-D%NPTRLS(MYSETW)+1 - DO JL=D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL),& - &D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL)+D%NONL(IGL,ISETB)-1 + DO JL=1,D%NONL(IGL,ISETB) IPOS = IPOS+1 - KINDEX(IPOS+INDOFF(JROC)) = JL + ! offset to first layer of this gridpoint + IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_OFFSET(JROC)+IPOS,1) = & + & KF_FS*D%NSTAGTF(IGLL)+(D%NSTA(IGL,ISETB)-1)+(JL-1) + ! distance between two layers of this gridpoint + IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_OFFSET(JROC)+IPOS,2) = & + & D%NSTAGTF(IGLL+1)-D%NSTAGTF(IGLL) ENDDO ENDDO - ENDIF - - ENDDO - - ISENDCOUNT=0 - IRECVCOUNT=0 - DO J=1,NPROC - ISENDCOUNT=MAX(ISENDCOUNT,ISENDTOT(J)) - IRECVCOUNT=MAX(IRECVCOUNT,IRECVTOT(J)) - ENDDO - - IF (IBUFLENS > 0) ALLOCATE(ZCOMBUFS(ISENDCOUNT,INSEND)) - IF (IBUFLENR > 0) ALLOCATE(ZCOMBUFR(IRECVCOUNT,INRECV)) - !$ACC DATA IF(IBUFLENS > 0) CREATE(ZCOMBUFS) - !$ACC DATA IF(IBUFLENR > 0) CREATE(ZCOMBUFR) - - !$ACC KERNELS DEFAULT(NONE) - IF (IBUFLENS > 0) ZCOMBUFS(:,:) = 0. - IF (IBUFLENR > 0) ZCOMBUFR(:,:) = 0. - !$ACC END KERNELS - - CALL GSTATS(1805,1) - - ! Send loop............................................................. - - ! Copy local contribution - !$ACC DATA PRESENT(PGLAT) COPYIN(KPTRGP,INDOFF,KINDEX) - !$ACC DATA IF(PRESENT(PGP)) PRESENT(PGP) COPYIN(IGPTROFF) - !$ACC DATA IF(PRESENT(PGPUV)) PRESENT(PGPUV) COPYIN(IUVLEVS,IUVPARS) - !$ACC DATA IF(PRESENT(PGP2)) PRESENT(PGP2) COPYIN(IGP2PARS) - !$ACC DATA IF(PRESENT(PGP3A)) PRESENT(PGP3A) COPYIN(IGP3ALEVS,IGP3APARS) - !$ACC DATA IF(PRESENT(PGP3B)) PRESENT(PGP3B) COPYIN(IGP3BLEVS,IGP3BPARS) - - IF(ISENDTOT(MYPROC) > 0 )THEN - IFLDS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == MYSETV .OR. KVSET(JFLD) == -1) THEN - IFLDS = IFLDS+1 - IF(LLINDER) THEN - IFLDOFF(IFLDS) = KPTRGP(JFLD) - ELSE - IFLDOFF(IFLDS) = JFLD - ENDIF - ENDIF - ENDDO - - IPOS=0 - JK_MAX = 0 - DO JBLK=1,NGPBLKS - IGPTROFF(JBLK)=IPOS - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,MYSETW) - IPOS=IPOS+ILAST-IFIRST+1 - IF (JK_MAX<(ILAST-IFIRST+1)) JK_MAX = (ILAST-IFIRST+1) - ENDIF + !we always receive the full fourier space + IRECVTOT(JROC) = IPOS*KF_FS ENDDO - !$ACC DATA COPYIN(IFLDOFF,IGPTROFF) - - CALL GSTATS(1601,0) - IF(LLPGPONLY) THEN - !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IPOS,IFIRST,ILAST,IFLD,JK) - DO JBLK=1,NGPBLKS - DO JFLD=1,IFLDS - DO JKL=1, JK_MAX - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - ILAST = IGPTRSEND(2,JBLK,MYSETW) - JK = JKL+IFIRST-1 - IF(IFIRST > 0 .AND. JK <= ILAST) THEN - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - IFLD = IFLDOFF(JFLD) - PGLAT(JFLD,KINDEX(IPOS)) = PGP(JK,IFLD,JBLK) - ENDIF - ENDDO - ENDDO - ENDDO - ELSE - !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IPOS,IFIRST,ILAST,IFLD,JK) - DO JBLK=1,NGPBLKS - DO JFLD=1,IFLDS - DO JKL=1, JK_MAX - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - ILAST = IGPTRSEND(2,JBLK,MYSETW) - JK = JKL+IFIRST-1 - IF(IFIRST > 0 .AND. JK <= ILAST) THEN - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - IFLD = IFLDOFF(JFLD) - IF(LLUV(IFLD)) THEN - PGLAT(JFLD,KINDEX(IPOS)) = PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) - ELSEIF(LLGP2(IFLD)) THEN - PGLAT(JFLD,KINDEX(IPOS)) = PGP2(JK,IGP2PARS(IFLD),JBLK) - ELSEIF(LLGP3A(IFLD)) THEN - PGLAT(JFLD,KINDEX(IPOS)) = PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK) - ELSEIF(LLGP3B(IFLD)) THEN - PGLAT(JFLD,KINDEX(IPOS)) = PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF - CALL GSTATS(1601,1) - - !$ACC END DATA - - ENDIF - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - !....Pack loop......................................................... - - CALL GSTATS(1602,0) - DO INS=1,INSEND - ISEND=JSEND(INS) - CALL PE2SET(ISEND,ISETA,ISETB,ISETW,ISETV) - ISENDSET = ISETV - ISEND_FLD_END = ISEND_FLD_TOTAL(ISEND) - IFLD = 0 - IPOS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == ISENDSET .OR. KVSET(JFLD) == -1 ) THEN - IFLD = IFLD+1 - IFLDA(IFLD)=JFLD - ENDIF - ENDDO - - JK_MAX = 0 - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,ISETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,ISETW) - IJPOS(JBLK)=IPOS - IPOS = IPOS+ILAST-IFIRST+1 - IF (JK_MAX<(ILAST-IFIRST+1)) JK_MAX = (ILAST-IFIRST+1) - ENDIF - ENDDO - - - !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(JK,JI,IFLDT,IFIRST,ILAST) COPYIN(INS,JK_MAX,IJPOS,IFLDA) - DO JJ=1,ISEND_FLD_END - DO JBLK=1,NGPBLKS - DO JKL=1, JK_MAX - IFLDT=IFLDA(JJ) - IFIRST = IGPTRSEND(1,JBLK,ISETW) - ILAST = IGPTRSEND(2,JBLK,ISETW) - JK = JKL+IFIRST-1 - JI=(JJ-1)*IPOS+IJPOS(JBLK)+JKL - IF(IFIRST > 0 .AND. JK <= ILAST) THEN - IF(LLINDER) THEN - ZCOMBUFS(JI,INS) = PGP(JK,KPTRGP(IFLDT),JBLK) - ELSEIF(LLPGPONLY) THEN - ZCOMBUFS(JI,INS) = PGP(JK,IFLDT,JBLK) - ELSEIF(LLUV(IFLDT)) THEN - ZCOMBUFS(JI,INS) = PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) - ELSEIF(LLGP2(IFLDT)) THEN - ZCOMBUFS(JI,INS) = PGP2(JK,IGP2PARS(IFLDT),JBLK) - ELSEIF(LLGP3A(IFLDT)) THEN - ZCOMBUFS(JI,INS) = PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) - ELSEIF(LLGP3B(IFLDT)) THEN - ZCOMBUFS(JI,INS) = PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - - ICOMBUFS_FLD(INS) = IFLD - ENDDO + CALL ASSIGN_PTR(PREEL_REAL, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFR_AND_REEL),& + & KF_FS*D%NLENGTF*SIZEOF(PREEL_REAL(1))+1, KF_FS*D%NLENGTF*SIZEOF(PREEL_REAL(1))) + !$ACC DATA COPYIN(IRECV_BUFR_TO_OUT,PGP_INDICES) PRESENT(PREEL_REAL) ASYNC(1) - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - CALL MPI_COMM_RANK(MPI_COMM_WORLD, IRANK, IERROR) - !IF(irank==0) WRITE(*,*) "packing (trgtol) in sec: ", Tc - #endif - - CALL GSTATS(1602,1) - - IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',0,ZHOOK_HANDLE_BAR) - CALL GSTATS_BARRIER(761) - IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',1,ZHOOK_HANDLE_BAR) - - IF(.NOT.LGPNORM)THEN - CALL GSTATS(803,0) - ELSE - CALL GSTATS(804,0) - ENDIF - IR=0 - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - IF (LSYNC_TRANS) THEN - CALL GSTATS(423,0) - CALL MPL_BARRIER(CDSTRING='TRGTOL BARRIER') - CALL GSTATS(423,1) - ENDIF - CALL GSTATS(413,0) - - !$ACC HOST_DATA USE_DEVICE(ZCOMBUFR,ZCOMBUFS) - ! Receive loop......................................................... - DO INR=1,INRECV - IR=IR+1 - IRECV=JRECV(INR) - CALL MPI_IRECV(ZCOMBUFR(1:IRECVTOT(IRECV),INR),IRECVTOT(IRECV), & - & TRGTOL_DTYPE,NPRCIDS(IRECV)-1,ITAG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) - IR=IR+1 - CALL MPI_IRECV(ICOMBUFR_FLD(INR),1, & - & MPI_INTEGER,NPRCIDS(IRECV)-1,ITAG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) - ENDDO - - !....Send loop......................................................... - DO INS=1,INSEND - IR=IR+1 - ISEND=JSEND(INS) - CALL MPI_ISEND(ZCOMBUFS(1:ISENDTOT(ISEND),INS),ISENDTOT(ISEND), & - & TRGTOL_DTYPE,NPRCIDS(ISEND)-1,ITAG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) - IR=IR+1 - CALL MPI_ISEND(ICOMBUFS_FLD(INS),1, & - & MPI_INTEGER,NPRCIDS(ISEND)-1,ITAG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) - ENDDO - !$ACC END HOST_DATA - - IF(IR > 0) THEN - CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & - & CDSTRING='TRGTOL_CUDAAWARE: WAIT FOR SENDS AND RECEIVES') - ENDIF - CALL GSTATS(413,1) - - !#ifdef COMVERBOSE - ! call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - ! Tc=(TIMEF()-Tc)/1000.0_JPRBT - ! !IF(irank==0) WRITE(*,*) "non-CUDA-aware isend/irecv (trgtol) in sec: ", Tc - !#endif - - IF(.NOT.LGPNORM)THEN - CALL GSTATS(803,1) - ELSE - CALL GSTATS(804,1) - ENDIF - CALL GSTATS_BARRIER2(761) - - !#ifdef COMVERBOSE - ! call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - ! Tc=TIMEF() - !#endif - ! Unpack loop......................................................... - - CALL GSTATS(1603,0) - - - DO INR=1,INRECV - IRECV=JRECV(INR) - ILEN = IRECVTOT(IRECV)/KF_FS - IRECV_FLD_END = ICOMBUFR_FLD(INR) - !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(II) COPYIN(IRECV,ILEN,IRECV_FLD_END) - DO JFLD=1,IRECV_FLD_END - DO JL=1,ILEN - II = KINDEX(INDOFF(IRECV)+JL) - PGLAT(JFLD,II) = ZCOMBUFR(JL+(JFLD-1)*ILEN,INR) - ENDDO - ENDDO - ENDDO - !$ACC END DATA - - !#ifdef COMVERBOSE - ! call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - ! Tc=(TIMEF()-Tc)/1000.0_JPRBT - ! !IF(irank==0) WRITE(*,*) "unpacking (trgtol) in sec: ", Tc - !#endif - - CALL GSTATS(1603,1) - - !$ACC END DATA !! PRESENT(PGP3B) - !$ACC END DATA !! PRESENT(PGP3A) - !$ACC END DATA !! PRESENT(PGP2) - !$ACC END DATA !! PRESENT(PGPUV) - !$ACC END DATA !! PRESENT(PGP) - !$ACC END DATA !! PRESENT(PGLAT) - - !$ACC END DATA !! ZCOMBUFS - !$ACC END DATA !! ZCOMBUFS - - IF (IBUFLENS > 0) DEALLOCATE(ZCOMBUFS) - IF (IBUFLENR > 0) DEALLOCATE(ZCOMBUFR) - - IF (LHOOK) CALL DR_HOOK('TRGTOL_CUDAAWARE',1,ZHOOK_HANDLE) - - END SUBROUTINE TRGTOL_CUDAAWARE - - SUBROUTINE TRGTOL(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) - - !**** *TRGTOL * - transposition of grid point data from column - ! structure to latitudinal. Reorganize data between - ! grid point calculations and direct Fourier Transform - - ! Purpose. - ! -------- - - - !** Interface. - ! ---------- - ! *call* *trgtol(...) - - ! Explicit arguments : - ! -------------------- - ! PGLAT - Latitudinal data ready for direct FFT (output) - ! PGP - Blocked grid point data (input) - - ! Implicit arguments : - ! -------------------- - - ! Method. - ! ------- - ! See documentation - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! MPP Group *ECMWF* - - ! Modifications. - ! -------------- - ! Original: 95-10-01 - ! D.Dent : 97-08-04 Reorganisation to allow - ! NPRTRV to differ from NPRGPEW - ! : 98-06-17 add mailbox control logic (from TRLTOM) - ! =99-03-29= Mats Hamrud and Deborah Salmond - ! JUMP in FFT's changed to 1 - ! KINDEX introduced and ZCOMBUF not used for same PE - ! 01-11-23 Deborah Salmond and John Hague - ! LIMP_NOOLAP Option for non-overlapping message passing - ! and buffer packing - ! 01-12-18 Peter Towers - ! Improved vector performance of GTOL_PACK,GTOL_UNPACK - ! 03-04-02 G. Radnoti: call barrier always when nproc>1 - ! 08-01-01 G.Mozdzynski: cleanup - ! 09-01-02 G.Mozdzynski: use non-blocking recv and send - ! ------------------------------------------------------------------ - - - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD - - USE TPM_GEN ,ONLY : NOUT - USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRNS, MTAGGL, & - & MYSETV, MYSETW, MYPROC, NPROC - USE TPM_TRANS ,ONLY : LDIVGP, LGPNORM, LSCDERS, LUVDER, LVORGP, NGPBLKS - - USE INIGPTR_MOD ,ONLY : INIGPTR - USE PE2SET_MOD ,ONLY : PE2SET - !USE MYSENDSET_MOD - !USE MYRECVSET_MOD - USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS - ! - USE MPI - - IMPLICIT NONE - - REAL(KIND=JPRBT),INTENT(OUT) :: PGLAT(:,:) - INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(:) - INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP - INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G - INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) - - REAL(KIND=JPRBT),ALLOCATABLE :: ZCOMBUFS(:,:),ZCOMBUFR(:,:) - REAL(KIND=JPRBT) :: ZDUM(2) - - INTEGER(KIND=JPIM) :: ISENT (NPROC) - INTEGER(KIND=JPIM) :: IRCVD (NPROC) - INTEGER(KIND=JPIM) :: ISENDTOT (NPROC) - INTEGER(KIND=JPIM) :: IRECVTOT (NPROC) - INTEGER(KIND=JPIM) :: IREQ (NPROC*2) - INTEGER(KIND=JPIM) :: JRECV (NPROC) - INTEGER(KIND=JPIM) :: JSEND (NPROC) - - ! LOCAL INTEGER SCALARS - INTEGER(KIND=JPIM) :: IFIRST, IFIRSTLAT, IGL, IGLL, ILAST,& - &ILASTLAT, ILEN, JROC, IPOS, ISETA, & - &ISETB, IRECV, IRECVSET, & - &ISETV, ISEND, ISENDSET, ITAG, J, JBLK, JFLD, & - &JGL, JK, JL, JLOOP, ISETW, IFLD, & - &II,INDOFFX,IBUFLENS,IBUFLENR,INRECV, IPROC,IFLDS, & - &INSEND,INS,INR,IR, iunit - - ! LOCAL LOGICAL SCALARS - LOGICAL :: LLPGPUV,LLPGP3A,LLPGP3B,LLPGP2,LLPGPONLY - LOGICAL :: LLUV(KF_GP),LLGP2(KF_GP),LLGP3A(KF_GP),LLGP3B(KF_GP) - LOGICAL :: LLDONE, LLINDER - INTEGER(KIND=JPIM) :: IUVLEVS(KF_GP),IUVPARS(KF_GP),IGP2PARS(KF_GP) - INTEGER(KIND=JPIM) :: IGP3APARS(KF_GP),IGP3ALEVS(KF_GP),IGP3BPARS(KF_GP),IGP3BLEVS(KF_GP) - INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF - INTEGER(KIND=JPIM) :: IOFF,IOFF1,IOFFNS,IOFFEW,J1,J2 - INTEGER(KIND=JPIM) :: KINDEX(D%NLENGTF),INDOFF(NPROC),IFLDOFF(MAX(KF_GP,KF_FS)) - INTEGER(KIND=JPIM) :: ISEND_FLD_TOTAL(NPROC),ISEND_FLD_START(NPROC),ISEND_FLD_END - INTEGER(KIND=JPIM) :: IRECV_FLD_START,IRECV_FLD_END - INTEGER(KIND=JPIM) :: INUMFLDS - INTEGER(KIND=JPIM) :: IGPTRSEND(2,NGPBLKS,NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTRRECV(NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTROFF(NGPBLKS) - ! INTEGER FUNCTIONS - INTEGER(KIND=JPIM) :: IRECVCOUNT,ISENDCOUNT - INTEGER(KIND=JPIM) :: IJPOS(NGPBLKS),IFLDA(KF_GP),JJ,JI,IFLDT - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR - - INTEGER(KIND=JPIM) :: IERROR, irank - - REAL(KIND=JPRBT) :: TIMEF, tc - - ! ------------------------------------------------------------------ - - !* 0. Some initializations - ! -------------------- - - IF (LHOOK) CALL DR_HOOK('TRGTOL',0,ZHOOK_HANDLE) - - iunit=300+myproc - - CALL GSTATS(1805,0) - - LLINDER = .FALSE. - LLPGPUV = .FALSE. - LLPGP3A = .FALSE. - LLPGP3B = .FALSE. - LLPGP2 = .FALSE. - LLPGPONLY = .FALSE. - IF(PRESENT(KPTRGP)) LLINDER = .TRUE. - IF(PRESENT(PGP)) LLPGPONLY = .TRUE. - IF(PRESENT(PGPUV)) LLPGPUV = .TRUE. - IF(PRESENT(PGP3A)) LLPGP3A = .TRUE. - IF(PRESENT(PGP3B)) LLPGP3B = .TRUE. - IF(PRESENT(PGP2)) LLPGP2 = .TRUE. - IUVPAR=0 - IUVLEV=0 - IOFF1=0 - IOFFNS=KF_SCALARS_G - IOFFEW=2*KF_SCALARS_G - LLUV(:) = .FALSE. - IUVPARS(:) = -99 - IUVLEVS(:) = -99 - IF (LLPGPUV) THEN - IOFF=0 - IUVLEV=UBOUND(PGPUV,2) - IF(LVORGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV + CALL GSTATS(1805,1) + + ! Put data on device for copyin + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) ENDIF - IF(LDIVGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV + CALL GSTATS(412,0) + ACC_POINTERS_CNT = 0 + IF (PRESENT(PGP)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP) ENDIF - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - ENDDO - IUVPAR=IUVPAR+2 - LLUV(IOFF+1:IOFF+2*IUVLEV)=.TRUE. - IOFF=IOFF+2*IUVLEV - IOFF1=IOFF - IOFFNS=IOFFNS+IOFF - IOFFEW=IOFFEW+IOFF - IOFF=IUVPAR*IUVLEV+KF_SCALARS_G - IF(LUVDER) THEN - IF(LSCDERS) IOFF=IOFF+KF_SCALARS_G - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - LLUV(IOFF+J)=.TRUE. - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - LLUV(IOFF+J+IUVLEV)=.TRUE. - ENDDO - IUVPAR=IUVPAR+2 - IOFF=IOFF+2*IUVLEV - IOFFEW=IOFFEW+2*IUVLEV + IF (PRESENT(PGPUV)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGPUV) ENDIF - ENDIF - LLGP2(:)=.FALSE. - IF(LLPGP2) THEN - IOFF=IOFF1 - IGP2PAR=UBOUND(PGP2,2) - IF(LSCDERS) IGP2PAR=IGP2PAR/3 - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J - ENDDO - IOFF1=IOFF1+IGP2PAR - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+IGP2PAR - ENDDO - IOFFNS=IOFF+IGP2PAR - IOFF=IOFFEW - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+2*IGP2PAR - ENDDO - IOFFEW=IOFF+IGP2PAR + IF (PRESENT(PGP2)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP2) ENDIF - ENDIF - LLGP3A(:) = .FALSE. - IF(LLPGP3A) THEN - IGP3ALEV=UBOUND(PGP3A,2) - IGP3APAR=UBOUND(PGP3A,3) - IF(LSCDERS) IGP3APAR=IGP3APAR/3 - IOFF=IOFF1 - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1 - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IGP3APAR - IOFF1=IOFF1+IGP3APAR*IGP3ALEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3APAR - IOFFNS=IOFFNS+IGP3APAR*IGP3ALEV - IOFF=IOFFEW - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IOFFEW=IOFFEW+IGP3APAR*IGP3ALEV + IF (PRESENT(PGP3A)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3A) ENDIF - ENDIF - LLGP3B(:) = .FALSE. - IF(LLPGP3B) THEN - IGP3BLEV=UBOUND(PGP3B,2) - IGP3BPAR=UBOUND(PGP3B,3) - IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 - IOFF=IOFF1 - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1 - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IGP3BPAR - IOFF1=IOFF1+IGP3BPAR*IGP3BLEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3BPAR - IOFFNS=IOFFNS+IGP3BPAR*IGP3BLEV - IOFF=IOFFEW - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IOFFEW=IOFFEW+IGP3BPAR*IGP3BLEV + IF (PRESENT(PGP3B)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3B) ENDIF - ENDIF - - - CALL INIGPTR(IGPTRSEND,IGPTRRECV) - LLDONE = .FALSE. - - ITAG = MTAGGL - - INDOFFX = 0 - IBUFLENS = 0 - IBUFLENR = 0 - INRECV = 0 - INSEND = 0 - - DO JROC=1,NPROC - - CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) - IRECVSET = ISETA - ISEND = JROC - ISENDSET = ISETV - ISENT(JROC) = 0 - IRCVD(JROC) = 0 - - ! count up expected number of fields - IPOS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == ISENDSET .OR. KVSET(JFLD) == -1) IPOS = IPOS+1 - ENDDO - ISEND_FLD_TOTAL(JROC) = IPOS - ISENDTOT(JROC) = IGPTRRECV(ISETW)*IPOS - - IF( JROC /= MYPROC) THEN - IBUFLENS = MAX(IBUFLENS,ISENDTOT(JROC)) - IF(ISENDTOT(JROC) > 0) THEN - INSEND = INSEND+1 - JSEND(INSEND)=JROC - ENDIF + IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_CREATE(ACC_POINTERS(1:ACC_POINTERS_CNT),STREAM=1_ACC_HANDLE_KIND) + IF (PRESENT(PGP)) THEN + !$ACC UPDATE DEVICE(PGP) ASYNC(1) ENDIF - - IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(IRECVSET)) - ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(IRECVSET)) - - IPOS = 0 - DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(IRECVSET)+JGL-D%NFRSTLAT(IRECVSET) - IPOS = IPOS+D%NONL(IGL,ISETB) - ENDDO - - IRECVTOT(JROC) = IPOS*KF_FS - - IF(IRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN - INRECV = INRECV + 1 - JRECV(INRECV)=JROC + IF (PRESENT(PGPUV)) THEN + !$ACC UPDATE DEVICE(PGPUV) ASYNC(1) ENDIF - - IF( JROC /= MYPROC) IBUFLENR = MAX(IBUFLENR,IRECVTOT(JROC)) - - IF(IPOS > 0) THEN - INDOFF(JROC) = INDOFFX - INDOFFX = INDOFFX+IPOS - IPOS = 0 - DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(IRECVSET)+JGL-D%NFRSTLAT(IRECVSET) - IGLL = JGL-D%NPTRLS(MYSETW)+1 - DO JL=D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL),& - &D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL)+D%NONL(IGL,ISETB)-1 - IPOS = IPOS+1 - KINDEX(IPOS+INDOFF(JROC)) = JL - ENDDO - ENDDO + IF (PRESENT(PGP2)) THEN + !$ACC UPDATE DEVICE(PGP2) ASYNC(1) + ENDIF + IF (PRESENT(PGP3A)) THEN + !$ACC UPDATE DEVICE(PGP3A) ASYNC(1) ENDIF - - ENDDO - - ISENDCOUNT=0 - IRECVCOUNT=0 - DO J=1,NPROC - ISENDCOUNT=MAX(ISENDCOUNT,ISENDTOT(J)) - IRECVCOUNT=MAX(IRECVCOUNT,IRECVTOT(J)) - ENDDO - IF (IBUFLENS > 0) ALLOCATE(ZCOMBUFS(-1:ISENDCOUNT,INSEND)) - IF (IBUFLENR > 0) ALLOCATE(ZCOMBUFR(-1:IRECVCOUNT,INRECV)) - - CALL GSTATS(1805,1) - - ! Send loop............................................................. - - ! Copy local contribution - - IF(ISENDTOT(MYPROC) > 0 )THEN - IFLDS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == MYSETV .OR. KVSET(JFLD) == -1) THEN - IFLDS = IFLDS+1 - IF(LLINDER) THEN - IFLDOFF(IFLDS) = KPTRGP(JFLD) - ELSE - IFLDOFF(IFLDS) = JFLD + IF (PRESENT(PGP3B)) THEN + !$ACC UPDATE DEVICE(PGP3B) ASYNC(1) + ENDIF + !$ACC DATA IF(PRESENT(PGP)) PRESENT(PGP) ASYNC(1) + !$ACC DATA IF(PRESENT(PGPUV)) PRESENT(PGPUV) ASYNC(1) + !$ACC DATA IF(PRESENT(PGP2)) PRESENT(PGP2) ASYNC(1) + !$ACC DATA IF(PRESENT(PGP3A)) PRESENT(PGP3A) ASYNC(1) + !$ACC DATA IF(PRESENT(PGP3B)) PRESENT(PGP3B) ASYNC(1) + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(432,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(432,1) + ENDIF + CALL GSTATS(412,1) + + ! Figure out processes that send or recv something + ISEND_COUNTS = 0 + IRECV_COUNTS = 0 + DO JROC=1,NPROC + IF( JROC /= MYPROC) THEN + IF(IRECVTOT(JROC) > 0) THEN + ! I have to recv something, so let me store that + IRECV_COUNTS = IRECV_COUNTS + 1 + IRECV_TO_PROC(IRECV_COUNTS)=JROC + ENDIF + IF(ISENDTOT(JROC) > 0) THEN + ! I have to send something, so let me store that + ISEND_COUNTS = ISEND_COUNTS+1 + ISEND_TO_PROC(ISEND_COUNTS)=JROC ENDIF ENDIF ENDDO - - IPOS=0 - DO JBLK=1,NGPBLKS - IGPTROFF(JBLK)=IPOS - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,MYSETW) - IPOS=IPOS+ILAST-IFIRST+1 - ENDIF + + ALLOCATE(ICOMBUFS_OFFSET(ISEND_COUNTS+1)) + ICOMBUFS_OFFSET(1) = 0 + DO JROC=1,ISEND_COUNTS + ICOMBUFS_OFFSET(JROC+1) = ICOMBUFS_OFFSET(JROC) + ISENDTOT(ISEND_TO_PROC(JROC)) ENDDO + ALLOCATE(ICOMBUFR_OFFSET(IRECV_COUNTS+1)) + ICOMBUFR_OFFSET(1) = 0 + DO JROC=1,IRECV_COUNTS + ICOMBUFR_OFFSET(JROC+1) = ICOMBUFR_OFFSET(JROC) + IRECVTOT(IRECV_TO_PROC(JROC)) + ENDDO + + IF (ISEND_COUNTS > 0) THEN + CALL ASSIGN_PTR(ZCOMBUFS, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFS),& + & 1_C_SIZE_T, ICOMBUFS_OFFSET(ISEND_COUNTS+1)*SIZEOF(ZCOMBUFS(1))) + ENDIF + + !....Pack loop......................................................... + !$ACC DATA IF(ISEND_COUNTS > 0) PRESENT(ZCOMBUFS) ASYNC(1) + + CALL GSTATS(1602,0) + DO INS=1,ISEND_COUNTS + ISEND=ISEND_TO_PROC(INS) + CALL PE2SET(ISEND,ISETA,ISETB,ISETW,ISETV) - CALL GSTATS(1601,0) - #ifdef NECSX - !$OMP PARALLEL DO SCHEDULE(DYNAMIC) PRIVATE(JFLD,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) - #else - !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) - #endif - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,MYSETW) - IF(LLPGPONLY) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) - PGLAT(JFLD,KINDEX(IPOS)) = PGP(JK,IFLD,JBLK) - ENDDO + ISEND_FIELD_COUNT_V = ISEND_FIELD_COUNT(ISETV) + ICOMBUFS_OFFSET_V = ICOMBUFS_OFFSET(INS) + + IFLDS = 0 + DO JFLD=1,KF_GP + IF(IVSET(JFLD) == ISETV .OR. IVSET(JFLD) == -1 ) THEN + IFLDS = IFLDS+1 + IF(PRESENT(KPTRGP)) THEN + IFLDA(IFLDS)=KPTRGP(JFLD) + ELSE + IFLDA(IFLDS)=JFLD + ENDIF + ENDIF + ENDDO + + !$ACC DATA COPYIN(IFLDA(1:ISEND_FIELD_COUNT_V)) ASYNC(1) + + ISEND_WSET_OFFSET_V = ISEND_WSET_OFFSET(ISETW) + ISEND_WSET_SIZE_V = ISEND_WSET_SIZE(ISETW) + IF(PRESENT(PGP)) THEN + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI) ASYNC(1) + DO JFLD=1,ISEND_FIELD_COUNT_V + DO JL=1,ISEND_WSET_SIZE_V + JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD = IFLDA(JFLD) + JI = (JFLD-1)*ISEND_WSET_SIZE_V+JL + ZCOMBUFS(ICOMBUFS_OFFSET_V+JI) = PGP(JK,IFLD,JBLK) ENDDO - ELSE - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) - IF(LLUV(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) - !if(jfld<=5 .and. kindex(ipos)<5) write(nout,*)'trgtol: ipos=',ipos,' idx=',kindex(ipos),' jk=',jk,' lev=',iuvlevs(ifld),' pars=',iuvpars(ifld),' pglat=',PGLAT(JFLD,KINDEX(IPOS)) - !if( jfld.eq.1 ) write(nout,*)'trgtoluv: ',kindex(ipos),' lev=',iuvlevs(ifld),' pars=',iuvpars(ifld),' pglat=',PGLAT(JFLD,KINDEX(IPOS)) - ENDDO - ELSEIF(LLGP2(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP2(JK,IGP2PARS(IFLD),JBLK) - ENDDO - ELSEIF(LLGP3A(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK) - !if( jk.eq.ifirst ) write(iunit,*)'trgtol: ',JK,JFLD,IFLD,kindex(ipos),' lev=',IGP3ALEVS(ifld),' pars=',IGP3APARS(ifld),' pglat=',PGLAT(JFLD,KINDEX(IPOS)) - ENDDO - ELSEIF(LLGP3B(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGLAT(JFLD,KINDEX(IPOS)) = PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK) - ENDDO - ELSE - CALL ABORT_TRANS('TRLTOG_MOD: ERROR') + ENDDO + ELSE + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI,IOFF) ASYNC(1) + DO JFLD=1,ISEND_FIELD_COUNT_V + DO JL=1,ISEND_WSET_SIZE_V + JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD = IFLDA(JFLD) + JI = ICOMBUFS_OFFSET_V+(JFLD-1)*ISEND_WSET_SIZE_V+JL + IF(IFLD < PGP_INDICES(PGP_INDICES_UV+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_UV) + PBOUND=UBOUND(PGPUV,2) + ! TODO we could certainly reshape PGPXX arrays and we would simplify this + ZCOMBUFS(JI) = PGPUV(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) + ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP2+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP2) + ZCOMBUFS(JI) = PGP2(JK,IOFF+1,JBLK) + ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3A+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3A) + PBOUND=UBOUND(PGP3A,2) + ZCOMBUFS(JI) = PGP3A(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) + ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3B+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3B) + PBOUND=UBOUND(PGP3B,2) + ZCOMBUFS(JI)= PGP3B(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ENDIF - ENDDO - ENDIF + ENDDO + ENDDO ENDIF + !$ACC END DATA ENDDO - !$OMP END PARALLEL DO - CALL GSTATS(1601,1) - - ENDIF - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - !....Pack loop......................................................... - - ISEND_FLD_START=1 - CALL GSTATS(1602,0) - !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(IFLDT,JBLK,IFIRST,ILAST,JK,JJ,JI,& - !$OMP& INS,ISEND,ISETA,ISETB,ISETW,ISETV,ISENDSET,ISEND_FLD_END,IFLD,IPOS,& - !$OMP& IFLDA,JFLD,IJPOS) - DO INS=1,INSEND - ISEND=JSEND(INS) - CALL PE2SET(ISEND,ISETA,ISETB,ISETW,ISETV) - ISENDSET = ISETV - ISEND_FLD_END = ISEND_FLD_TOTAL(ISEND) - IFLD = 0 - IPOS = 0 + !$ACC WAIT(1) + CALL GSTATS(1602,1) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) + ENDIF + + CALL GSTATS(411,0) + IF (IRECV_COUNTS > 0) THEN + CALL ASSIGN_PTR(ZCOMBUFR, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFR_AND_REEL),& + & 1_C_SIZE_T, ICOMBUFR_OFFSET(IRECV_COUNTS+1)*SIZEOF(ZCOMBUFR(1))) + ENDIF + !$ACC DATA IF(IRECV_COUNTS > 0) PRESENT(ZCOMBUFR) + + IR=0 + + !$ACC HOST_DATA USE_DEVICE(ZCOMBUFR,ZCOMBUFS) + ! Receive loop......................................................... + DO INR=1,IRECV_COUNTS + IR=IR+1 + IPROC=IRECV_TO_PROC(INR) + CALL MPI_IRECV(ZCOMBUFR(ICOMBUFR_OFFSET(INR)+1:ICOMBUFR_OFFSET(INR+1)),IRECVTOT(IPROC), & + & TRGTOL_DTYPE,NPRCIDS(IPROC)-1,MTAGLG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) + ENDDO + + !....Send loop......................................................... + DO INS=1,ISEND_COUNTS + IR=IR+1 + ISEND=ISEND_TO_PROC(INS) + CALL MPI_ISEND(ZCOMBUFS(ICOMBUFS_OFFSET(INS)+1:ICOMBUFS_OFFSET(INS+1)),ISENDTOT(ISEND), & + & TRGTOL_DTYPE,NPRCIDS(ISEND)-1,MTAGLG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) + ENDDO + !$ACC END HOST_DATA + + ! Copy local contribution + IF(ISENDTOT(MYPROC) > 0 )THEN + ! I have to send something to myself... + + ! Input is KF_GP fields. We find the resulting KF_FS fields. + IFLDS = 0 DO JFLD=1,KF_GP - IF(KVSET(JFLD) == ISENDSET .OR. KVSET(JFLD) == -1 ) THEN - IFLD = IFLD+1 - IFLDA(IFLD)=JFLD - ENDIF - ENDDO - - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,ISETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,ISETW) - IJPOS(JBLK)=IPOS - IPOS=IPOS+(ILAST-IFIRST+1) + IF(IVSET(JFLD) == MYSETV .OR. IVSET(JFLD) == -1) THEN + IFLDS = IFLDS+1 + IF(PRESENT(KPTRGP)) THEN + IFLDA(IFLDS) = KPTRGP(JFLD) + ELSE + IFLDA(IFLDS) = JFLD + ENDIF ENDIF ENDDO - - - DO JJ=ISEND_FLD_START(ISEND),ISEND_FLD_END - IFLDT=IFLDA(JJ) - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,ISETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,ISETW) - IF(LLINDER) THEN - DO JK=IFIRST,ILAST - JI=(JJ-ISEND_FLD_START(ISEND))*IPOS+IJPOS(JBLK)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP(JK,KPTRGP(IFLDT),JBLK) - ENDDO - ELSE - IF(LLPGPONLY) THEN - DO JK=IFIRST,ILAST - JI=(JJ-ISEND_FLD_START(ISEND))*IPOS+IJPOS(JBLK)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP(JK,IFLDT,JBLK) - ENDDO - ELSEIF(LLUV(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-ISEND_FLD_START(ISEND))*IPOS+IJPOS(JBLK)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) - ENDDO - ELSEIF(LLGP2(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-ISEND_FLD_START(ISEND))*IPOS+IJPOS(JBLK)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP2(JK,IGP2PARS(IFLDT),JBLK) - ENDDO - ELSEIF(LLGP3A(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-ISEND_FLD_START(ISEND))*IPOS+IJPOS(JBLK)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) - ENDDO - ELSEIF(LLGP3B(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-ISEND_FLD_START(ISEND))*IPOS+IJPOS(JBLK)+JK-IFIRST+1 - ZCOMBUFS(JI,INS) = PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) - ENDDO - ENDIF + + !$ACC DATA COPYIN(IFLDA(1:IFLDS)) ASYNC(1) + + ISEND_WSET_OFFSET_V = ISEND_WSET_OFFSET(MYSETW) + ISEND_WSET_SIZE_V = ISEND_WSET_SIZE(MYSETW) + IRECV_BUFR_TO_OUT_V = IRECV_BUFR_TO_OUT_OFFSET(MYPROC) + CALL GSTATS(1601,0) + IF(PRESENT(PGP)) THEN + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS,IOFF) ASYNC(1) + DO JFLD=1,KF_FS + DO JL=1,ISEND_WSET_SIZE_V + JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD = IFLDA(JFLD) + IPOS = IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,1)+ & + & (JFLD-1)*IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,2)+1 + PREEL_REAL(IPOS) = PGP(JK,IFLD,JBLK) + ENDDO + ENDDO + ELSE + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS,IOFF) ASYNC(1) + DO JFLD=1,KF_FS + DO JL=1,ISEND_WSET_SIZE_V + JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD = IFLDA(JFLD) + IPOS = IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,1)+ & + & (JFLD-1)*IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,2)+1 + IF(IFLD < PGP_INDICES(PGP_INDICES_UV+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_UV) + PBOUND=UBOUND(PGPUV,2) + PREEL_REAL(IPOS) = PGPUV(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) + ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP2+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP2) + PREEL_REAL(IPOS) = PGP2(JK,IOFF+1,JBLK) + ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3A+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3A) + PBOUND=UBOUND(PGP3A,2) + PREEL_REAL(IPOS) = PGP3A(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) + ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3B+1)) THEN + IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3B) + PBOUND=UBOUND(PGP3B,2) + PREEL_REAL(IPOS) = PGP3B(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ENDIF - ENDIF + ENDDO ENDDO - ENDDO - - IPOS=(ISEND_FLD_END-ISEND_FLD_START(ISEND)+1)*IPOS - ZCOMBUFS(-1,INS) = 1 - ZCOMBUFS(0,INS) = IFLD - ENDDO - !$OMP END PARALLEL DO - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - CALL MPI_COMM_RANK(MPI_COMM_WORLD, IRANK, IERROR) - !IF(irank==0) WRITE(*,*) "packing (trgtol) in sec: ", Tc - #endif - - CALL GSTATS(1602,1) - - IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',0,ZHOOK_HANDLE_BAR) - CALL GSTATS_BARRIER(761) - IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',1,ZHOOK_HANDLE_BAR) - - IF(.NOT.LGPNORM)THEN - CALL GSTATS(803,0) - ELSE - CALL GSTATS(804,0) - ENDIF - IR=0 - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - ! Receive loop......................................................... - DO INR=1,INRECV - IR=IR+1 - IRECV=JRECV(INR) - CALL MPL_RECV(ZCOMBUFR(-1:IRECVTOT(IRECV),INR), & - & KSOURCE=NPRCIDS(IRECV), & - & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), & - & KTAG=ITAG,CDSTRING='TRLTOG:' ) - !print*,irank,size(ZCOMBUFR(-1:IRECVTOT(IRECV),INR)) - ENDDO - - !....Send loop......................................................... - DO INS=1,INSEND - IR=IR+1 - ISEND=JSEND(INS) - CALL MPL_SEND(ZCOMBUFS(-1:ISENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & - & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), & - & KTAG=ITAG,CDSTRING='TRGTOL:' ) - ENDDO - - IF(IR > 0) THEN - CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & - & CDSTRING='TRGTOL: WAIT FOR SENDS AND RECEIVES') - ENDIF - - !#ifdef COMVERBOSE - ! call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - ! Tc=(TIMEF()-Tc)/1000.0_JPRBT - ! !IF(irank==0) WRITE(*,*) "non-CUDA-aware isend/irecv (trgtol) in sec: ", Tc - !#endif - - IF(.NOT.LGPNORM)THEN - CALL GSTATS(803,1) - ELSE - CALL GSTATS(804,1) - ENDIF - CALL GSTATS_BARRIER2(761) - - !#ifdef COMVERBOSE - ! call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - ! Tc=TIMEF() - !#endif - ! Unpack loop......................................................... - - CALL GSTATS(1603,0) - - - !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JL,II,JFLD,INR,IRECV,ILEN,IRECV_FLD_START,IRECV_FLD_END,IPOS) - DO INR=1,INRECV - IRECV=JRECV(INR) - ILEN = IRECVTOT(IRECV)/KF_FS - IRECV_FLD_START = ZCOMBUFR(-1,INR) - IRECV_FLD_END = ZCOMBUFR(0,INR) - DO JFLD=IRECV_FLD_START,IRECV_FLD_END + ENDIF + CALL GSTATS(1601,1) + + !$ACC END DATA + + ENDIF + + + IF(IR > 0) THEN + CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & + & CDSTRING='TRGTOL: WAIT FOR SENDS AND RECEIVES') + ENDIF + IF (LSYNC_TRANS) THEN + CALL GSTATS(431,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(431,1) + ENDIF + CALL GSTATS(411,1) + + ! Unpack loop......................................................... + + CALL GSTATS(1603,0) + DO INR=1,IRECV_COUNTS + IPROC=IRECV_TO_PROC(INR) + ILEN = IRECVTOT(IPROC)/KF_FS + IRECV_BUFR_TO_OUT_V = IRECV_BUFR_TO_OUT_OFFSET(IPROC) + ICOMBUFR_OFFSET_V = ICOMBUFR_OFFSET(INR) + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(II) ASYNC(1) + DO JFLD=1,KF_FS DO JL=1,ILEN - II = KINDEX(INDOFF(IRECV)+JL) - PGLAT(JFLD,II) = ZCOMBUFR(JL+(JFLD-IRECV_FLD_START)*ILEN,INR) + IPOS = IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,1)+ & + & (JFLD-1)*IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,2)+1 + PREEL_REAL(IPOS) = ZCOMBUFR(ICOMBUFR_OFFSET_V+JL+(JFLD-1)*ILEN) ENDDO ENDDO - ENDDO - !$OMP END PARALLEL DO - - ! this appears to be important (otherwise, old data picked in PGLAT) - ! in particular, one would have thought that above ACC copy and update on the - ! device is the same as OMP loop + update device command below, but it seems not, and winds still in field index 1 from prev inv_trans !!! - !$ACC update device(PGLAT) - !$ACC wait - - !#ifdef COMVERBOSE - ! call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - ! Tc=(TIMEF()-Tc)/1000.0_JPRBT - ! !IF(irank==0) WRITE(*,*) "unpacking (trgtol) in sec: ", Tc - !#endif - - CALL GSTATS(1603,1) - - IF (IBUFLENS > 0) DEALLOCATE(ZCOMBUFS) - IF (IBUFLENR > 0) DEALLOCATE(ZCOMBUFR) - - IF (LHOOK) CALL DR_HOOK('TRGTOL',1,ZHOOK_HANDLE) - + ENDDO + !$ACC WAIT(1) + CALL GSTATS(1603,1) + + !$ACC END DATA ! ZCOMBUFR + !$ACC END DATA ! IRECV_BUFR_TO_OUT,PGPINDICES + !$ACC END DATA !ZCOMBUFS (present) + !$ACC END DATA !PGP3B + !$ACC END DATA !PGP3A + !$ACC END DATA !PGP2 + !$ACC END DATA !PGPUV + !$ACC END DATA !PGP + IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_DELETE(ACC_POINTERS(1:ACC_POINTERS_CNT),STREAM=1_ACC_HANDLE_KIND) + + IF (LHOOK) CALL DR_HOOK('TRGTOL',1,ZHOOK_HANDLE) END SUBROUTINE TRGTOL - END MODULE TRGTOL_MOD +END MODULE TRGTOL_MOD diff --git a/src/trans/gpu/internal/trltog_mod.F90 b/src/trans/gpu/internal/trltog_mod.F90 index e83a8fd87..67bd18b5f 100755 --- a/src/trans/gpu/internal/trltog_mod.F90 +++ b/src/trans/gpu/internal/trltog_mod.F90 @@ -1,4 +1,6 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1995- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,1366 +10,771 @@ ! MODULE TRLTOG_MOD - CONTAINS - SUBROUTINE TRLTOG_CUDAAWARE(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) - - !**** *trltog * - transposition of grid point data from latitudinal - ! to column structure. This takes place between inverse - ! FFT and grid point calculations. - ! TRLTOG is the inverse of TRGTOL - - ! Version using CUDA-aware MPI - - ! Purpose. - ! -------- - - - !** Interface. - ! ---------- - ! *call* *trltog(...) - - ! Explicit arguments : - ! -------------------- - ! PGLAT - Latitudinal data ready for direct FFT (input) - ! PGP - Blocked grid point data (output) - ! KVSET - "v-set" for each field (input) - - ! Implicit arguments : - ! -------------------- - - ! Method. - ! ------- - ! See documentation - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! MPP Group *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 95-10-01 - ! D.Dent : 97-08-04 Reorganisation to allow NPRTRV - ! to differ from NPRGPEW - ! =99-03-29= Mats Hamrud and Deborah Salmond - ! JUMP in FFT's changed to 1 - ! INDEX introduced and ZCOMBUF not used for same PE - ! 01-11-23 Deborah Salmond and John Hague - ! LIMP_NOOLAP Option for non-overlapping message passing - ! and buffer packing - ! 01-12-18 Peter Towers - ! Improved vector performance of LTOG_PACK,LTOG_UNPACK - ! 03-0-02 G. Radnoti: Call barrier always when nproc>1 - ! 08-01-01 G.Mozdzynski: cleanup - ! 09-01-02 G.Mozdzynski: use non-blocking recv and send - ! ------------------------------------------------------------------ - - - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB , JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE MPL_MODULE ,ONLY : MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_MYRANK, MPL_BARRIER - - USE TPM_GEN ,ONLY : NOUT, LSYNC_TRANS - USE TPM_DISTR ,ONLY : D, MYSETV, MYSETW, MTAGLG, & - & NPRCIDS, NPRTRNS, MYPROC, NPROC - USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, NGPBLKS - - USE INIGPTR_MOD ,ONLY : INIGPTR - USE PE2SET_MOD ,ONLY : PE2SET - !USE MYSENDSET_MOD - !USE MYRECVSET_MOD - USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS - USE MPL_DATA_MODULE ,ONLY : MPL_COMM_OML - USE OML_MOD ,ONLY : OML_MY_THREAD - ! - USE MPI - + USE ALLOCATOR_MOD IMPLICIT NONE - - - REAL(KIND=JPRBT), INTENT(IN) :: PGLAT(:,:) - INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(:) - INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP - INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G - INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) - - ! LOCAL VARIABLES - - REAL(KIND=JPRBT),ALLOCATABLE :: ZCOMBUFS(:,:),ZCOMBUFR(:,:) - INTEGER(KIND=JPIM) :: ICOMR_KFFS(NPROC), ICOMS_KFFS(NPROC) - REAL(KIND=JPRBT) :: ZDUM(2) - - INTEGER(KIND=JPIM) :: ISENT (NPROC) - INTEGER(KIND=JPIM) :: IRCVD (NPROC) - INTEGER(KIND=JPIM) :: ISENDTOT (NPROC) - INTEGER(KIND=JPIM) :: IRECVTOT (NPROC) - INTEGER(KIND=JPIM) :: IREQ (NPROC*4) - INTEGER(KIND=JPIM) :: JSEND (NPROC) - INTEGER(KIND=JPIM) :: JRECV (NPROC) - - INTEGER(KIND=JPIM) :: IFIRST, IFIRSTLAT, IFLD, IGL, IGLL,& - &ILAST, ILASTLAT, IPOS, ISETA, & - &ISETB, IRECV, IRECVSET, & - &ISETV, ISEND, ITAG, JBLK, JFLD, & - &JGL, JK, JL, JLOOP, ISETW, IFLDS, IPROC,JROC, & - &INRECV, INSEND,INR,INS,IR, JKL, JK_MAX - INTEGER(KIND=JPIM) :: II,INDOFFX,ILEN,IBUFLENS,IBUFLENR - - LOGICAL :: LLPGPUV,LLPGP3A,LLPGP3B,LLPGP2,LLPGPONLY - LOGICAL :: LLUV(KF_GP),LLGP2(KF_GP),LLGP3A(KF_GP),LLGP3B(KF_GP) - LOGICAL :: LLDONE, LLINDER - INTEGER(KIND=JPIM) :: IUVLEVS(KF_GP),IUVPARS(KF_GP),IGP2PARS(KF_GP) - INTEGER(KIND=JPIM) :: IGP3APARS(KF_GP),IGP3ALEVS(KF_GP),IGP3BPARS(KF_GP),IGP3BLEVS(KF_GP) - INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF - INTEGER(KIND=JPIM) :: IOFF,IOFF1,IOFFNS,IOFFEW,J1,J2 - INTEGER(KIND=JPIM) :: KINDEX(D%NLENGTF),INDOFF(NPROC),IFLDOFF(KF_GP) - INTEGER(KIND=JPIM) :: IRECV_FLD_START,IRECV_FLD_END - INTEGER(KIND=JPIM) :: ISEND_FLD_START(NPROC),ISEND_FLD_END - INTEGER(KIND=JPIM) :: INUMFLDS - INTEGER(KIND=JPIM) :: IGPTRSEND(2,NGPBLKS,NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTRRECV(NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTROFF(NGPBLKS) - - ! INTEGER FUNCTIONS - INTEGER(KIND=JPIM) :: ISENDCOUNT,IRECVCOUNT,J - INTEGER(KIND=JPIM) :: JPOS(NGPBLKS),IFLDA(KF_GP),JI,JJ - INTEGER(KIND=JPIM) :: IFLDT - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR - - INTEGER(KIND=JPIM), DIMENSION(MPI_STATUS_SIZE,NPROC*2) :: ISTATUS - INTEGER(KIND=JPIM) :: IERROR - - REAL(KIND=JPRBT) :: TIMEF, Tc - - #ifdef PARKINDTRANS_SINGLE - #define TRLTOG_DTYPE MPI_REAL - #else - #define TRLTOG_DTYPE MPI_DOUBLE_PRECISION - #endif - - - ! ------------------------------------------------------------------ - - !* 0. Some initializations - ! -------------------- - IF (LHOOK) CALL DR_HOOK('TRLTOG',0,ZHOOK_HANDLE) - - - CALL GSTATS(1806,0) - - LLINDER = .FALSE. - LLPGPUV = .FALSE. - LLPGP3A = .FALSE. - LLPGP3B = .FALSE. - LLPGP2 = .FALSE. - LLPGPONLY = .FALSE. - IF(PRESENT(KPTRGP)) LLINDER=.TRUE. - IF(PRESENT(PGP)) LLPGPONLY=.TRUE. - IF(PRESENT(PGPUV)) LLPGPUV=.TRUE. - IF(PRESENT(PGP3A)) LLPGP3A=.TRUE. - IF(PRESENT(PGP3B)) LLPGP3B=.TRUE. - IF(PRESENT(PGP2)) LLPGP2=.TRUE. - - IUVPAR=0 - IUVLEV=0 - IOFF1=0 - IOFFNS=KF_SCALARS_G - IOFFEW=2*KF_SCALARS_G - - LLUV(:) = .FALSE. - IF (LLPGPUV) THEN + + PRIVATE + PUBLIC :: TRLTOG_CUDAAWARE, TRLTOG_HANDLE, PREPARE_TRLTOG + + TYPE TRLTOG_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HCOMBUFR_AND_COMBUFS + END TYPE +CONTAINS + FUNCTION PREPARE_TRLTOG(ALLOCATOR,KF_FS,KF_GP) RESULT(HTRLTOG) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP, KF_FS + TYPE(TRLTOG_HANDLE) :: HTRLTOG + + REAL(KIND=JPRBT) :: DUMMY + + INTEGER(KIND=C_SIZE_T) :: NELEM + + NELEM = ALIGN(KF_GP*D%NGPTOT*SIZEOF(DUMMY),128) ! ZCOMBUFR + NELEM = ALIGN(NELEM + KF_FS*D%NLENGTF*SIZEOF(DUMMY),128) !ZCOMBUFS upper obund + + HTRLTOG%HCOMBUFR_AND_COMBUFS = RESERVE(ALLOCATOR, NELEM) + END FUNCTION + + SUBROUTINE TRLTOG_CUDAAWARE(ALLOCATOR,HTRLTOG,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,KPTRGP,& + & KVSETUV,KVSETSC,KVSETSC3A,KVSETSC3B,KVSETSC2,& + & PGP,PGPUV,PGP3A,PGP3B,PGP2) + + !**** *trltog * - transposition of grid point data from latitudinal + ! to column structure. This takes place between inverse + ! FFT and grid point calculations. + ! TRLTOG is the inverse of TRGTOL + + ! Version using CUDA-aware MPI + + ! Purpose. + ! -------- + + + !** Interface. + ! ---------- + ! *call* *trltog(...) + + ! Explicit arguments : + ! -------------------- + ! PREEL_REAL - Latitudinal data ready for direct FFT (input) + ! PGP - Blocked grid point data (output) + ! KVSET - "v-set" for each field (input) + + ! Implicit arguments : + ! -------------------- + + ! Method. + ! ------- + ! See documentation + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! MPP Group *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 95-10-01 + ! D.Dent : 97-08-04 Reorganisation to allow NPRTRV + ! to differ from NPRGPEW + ! =99-03-29= Mats Hamrud and Deborah Salmond + ! JUMP in FFT's changed to 1 + ! INDEX introduced and ZCOMBUF not used for same PE + ! 01-11-23 Deborah Salmond and John Hague + ! LIMP_NOOLAP Option for non-overlapping message passing + ! and buffer packing + ! 01-12-18 Peter Towers + ! Improved vector performance of LTOG_PACK,LTOG_UNPACK + ! 03-0-02 G. Radnoti: Call barrier always when nproc>1 + ! 08-01-01 G.Mozdzynski: cleanup + ! 09-01-02 G.Mozdzynski: use non-blocking recv and send + ! ------------------------------------------------------------------ + + USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB , JPRBT + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE MPL_MODULE ,ONLY : MPL_WAIT, MPL_BARRIER + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS + USE TPM_DISTR ,ONLY : D,MYSETV, MYSETW, MTAGLG,NPRCIDS,MYPROC,NPROC,NPRTRW,NPRTRV + USE PE2SET_MOD ,ONLY : PE2SET + USE MPL_DATA_MODULE ,ONLY : MPL_COMM_OML + USE OML_MOD ,ONLY : OML_MY_THREAD + USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS + USE MPI + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, NPROMA + USE OPENACC_EXT + + IMPLICIT NONE + + REAL(KIND=JPRBT), INTENT(INOUT), POINTER :: PREEL_REAL(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP + INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G, KF_SCALARS_G + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) + REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) + REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) + REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) + REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) + REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) + INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) + + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRLTOG_HANDLE) :: HTRLTOG + + ! LOCAL VARIABLES + + REAL(KIND=JPRBT), POINTER :: ZCOMBUFS(:),ZCOMBUFR(:) + + INTEGER(KIND=JPIM) :: ISENDTOT (NPROC) + INTEGER(KIND=JPIM) :: IRECVTOT (NPROC) + INTEGER(KIND=JPIM) :: IREQ (NPROC*2) + INTEGER(KIND=JPIM) :: IRECV_TO_PROC(NPROC) + INTEGER(KIND=JPIM) :: ISEND_TO_PROC(NPROC) + + INTEGER(KIND=JPIM) :: JFLD, J, JI, J1, J2, JGL, JK, JL, IFLDS, JROC, INR, INS + INTEGER(KIND=JPIM) :: IFIRSTLAT, ILASTLAT, IFLD, IGL, IGLL,& + &IPOS, ISETA, ISETB, ISETV, ISEND, IRECV, ISETW, IPROC, & + &IR, ILOCAL_LAT, ISEND_COUNTS, IRECV_COUNTS, IERROR, II, ILEN, IBUFLENS, IBUFLENR, & + &JBLK, ILAT_STRIP + + ! Contains FIELD, PARS, LEVS + INTEGER(KIND=JPIM) :: IGP_OFFSETS(KF_GP,3) + INTEGER(KIND=JPIM), PARAMETER :: IGP_OFFSETS_UV=1, IGP_OFFSETS_GP2=2, IGP_OFFSETS_GP3A=3, IGP_OFFSETS_GP3B=4 + INTEGER(KIND=JPIM) :: IUVPAR,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF,IOFF + + INTEGER(KIND=JPIM) :: IFLDA(KF_GP) + INTEGER(KIND=JPIM) :: IIN_TO_SEND_BUFR(D%NLENGTF,2),IIN_TO_SEND_BUFR_OFFSET(NPROC), IIN_TO_SEND_BUFR_V + INTEGER(KIND=JPIM) :: IRECV_FIELD_COUNT(NPRTRV),IRECV_FIELD_COUNT_V + INTEGER(KIND=JPIM) :: IRECV_WSET_SIZE(NPRTRW),IRECV_WSET_SIZE_V + INTEGER(KIND=JPIM) :: IRECV_WSET_OFFSET(NPRTRW+1), IRECV_WSET_OFFSET_V + INTEGER(KIND=JPIM), ALLOCATABLE :: ICOMBUFS_OFFSET(:),ICOMBUFR_OFFSET(:) + INTEGER(KIND=JPIM) :: ICOMBUFS_OFFSET_V, ICOMBUFR_OFFSET_V + + INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) + INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) + INTEGER(KIND=JPIM) :: IVSET(KF_GP) + INTEGER(KIND=JPIM) :: J3,IFGP2,IFGP3A,IFGP3B + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR + + TYPE(EXT_ACC_ARR_DESC) :: ACC_POINTERS(5) ! at most 5 copyins... + INTEGER(KIND=JPIM) :: ACC_POINTERS_CNT = 0 + + #ifdef PARKINDTRANS_SINGLE + #define TRLTOG_DTYPE MPI_REAL + #else + #define TRLTOG_DTYPE MPI_DOUBLE_PRECISION + #endif + + + ! ------------------------------------------------------------------ + + !* 0. Some initializations + ! -------------------- + IF (LHOOK) CALL DR_HOOK('TRLTOG',0,ZHOOK_HANDLE) + + ! Note we have either + ! - KVSETUV and KVSETSC (with PGP, which has u, v, and scalar fields), or + ! - KVSETUV, KVSETSC2, KVSETSC3A KVSETSC3B (with PGPUV, GP3A, PGP3B and PGP2) + ! KVSETs are optionals. Their sizes canalso be inferred from KV_UV_G/KV_SCALARS_G (which + ! should match PSPXXX and PGPXXX arrays) + + + ! We first get the decomposition individually + IVSETUV(:) = -1 + IF (PRESENT(KVSETUV)) IVSETUV(:) = KVSETUV(:) + IVSETSC(:)=-1 + IF (PRESENT(KVSETSC)) THEN + IVSETSC(:) = KVSETSC(:) + ELSE + IOFF=0 + IF (PRESENT(KVSETSC2)) THEN + IVSETSC(IOFF+1:IOFF+SIZE(KVSETSC2))=KVSETSC2(:) + IOFF = IOFF+SIZE(KVSETSC2) + ENDIF + IF (PRESENT(KVSETSC3A)) THEN + DO J3=1,MERGE(UBOUND(PGP3A,3),UBOUND(PGP3A,3)/3,.NOT. LSCDERS) + IVSETSC(IOFF+1:IOFF+SIZE(KVSETSC3A))=KVSETSC3A(:) + IOFF=IOFF+SIZE(KVSETSC3A) + ENDDO + ENDIF + IF (PRESENT(KVSETSC3B)) THEN + ! If SCDERS is on, the size of PGP is 3X larger because it is + ! holding various derivatives. The problem is that those are + ! at different non-contiguous positions, hence we treat them + ! as separate fields + DO J3=1,MERGE(UBOUND(PGP3B,3),UBOUND(PGP3B,3)/3,.NOT. LSCDERS) + IVSETSC(IOFF+1:IOFF+SIZE(KVSETSC3B))=KVSETSC3B(:) + IOFF=IOFF+SIZE(KVSETSC3B) + ENDDO + ENDIF + IF (IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN + PRINT*, "TRLTOG: ERROR IN IVSETSC COMPUTATION" + STOP 39 + ENDIF + ENDIF + + ! Now from UV and Scalars decomposition we get the full decomposition IOFF=0 - IUVLEV=UBOUND(PGPUV,2) - IF(LVORGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV + IF (KF_UV_G > 0) THEN + IF (LVORGP) THEN + IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) + IOFF=IOFF+KF_UV_G + ENDIF + IF ( LDIVGP) THEN + IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) + IOFF=IOFF+KF_UV_G + ENDIF + IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) + IOFF=IOFF+KF_UV_G + IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) + IOFF=IOFF+KF_UV_G ENDIF - IF(LDIVGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV + IF (KF_SCALARS_G > 0) THEN + IVSET(IOFF+1:IOFF+KF_SCALARS_G) = IVSETSC(:) + IOFF=IOFF+KF_SCALARS_G + IF (LSCDERS) THEN + IVSET(IOFF+1:IOFF+KF_SCALARS_G) = IVSETSC(:) + IOFF=IOFF+KF_SCALARS_G + ENDIF ENDIF - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - ENDDO - IUVPAR=IUVPAR+2 - LLUV(IOFF+1:IOFF+2*IUVLEV)=.TRUE. - IOFF=IOFF+2*IUVLEV - IOFF1=IOFF - IOFFNS=IOFFNS+IOFF - IOFFEW=IOFFEW+IOFF - - IOFF=IUVPAR*IUVLEV+KF_SCALARS_G - IF(LUVDER) THEN - IF(LSCDERS) IOFF=IOFF+KF_SCALARS_G - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - LLUV(IOFF+J)=.TRUE. - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - LLUV(IOFF+J+IUVLEV)=.TRUE. - ENDDO - IUVPAR=IUVPAR+2 - IOFF=IOFF+2*IUVLEV - IOFFEW=IOFFEW+2*IUVLEV + IF (KF_UV_G > 0 .AND. LUVDER) THEN + IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) + IOFF=IOFF+KF_UV_G + IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) + IOFF=IOFF+KF_UV_G ENDIF - ENDIF - - LLGP2(:)=.FALSE. - IF(LLPGP2) THEN - IOFF=IOFF1 - IGP2PAR=UBOUND(PGP2,2) - IF(LSCDERS) IGP2PAR=IGP2PAR/3 - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J - ENDDO - IOFF1=IOFF1+IGP2PAR - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+IGP2PAR - ENDDO - IOFFNS=IOFF+IGP2PAR - IOFF=IOFFEW - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+2*IGP2PAR - ENDDO - IOFFEW=IOFF+IGP2PAR + IF (KF_SCALARS_G > 0) THEN + IF (LSCDERS) THEN + IVSET(IOFF+1:IOFF+KF_SCALARS_G) = IVSETSC(:) + IOFF=IOFF+KF_SCALARS_G + ENDIF ENDIF - ENDIF - - LLGP3A(:) = .FALSE. - IF(LLPGP3A) THEN - IGP3ALEV=UBOUND(PGP3A,2) - IGP3APAR=UBOUND(PGP3A,3) - IF(LSCDERS) IGP3APAR=IGP3APAR/3 - IOFF=IOFF1 - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1 - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IGP3APAR - IOFF1=IOFF1+IGP3APAR*IGP3ALEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3APAR - IOFFNS=IOFFNS+IGP3APAR*IGP3ALEV - IOFF=IOFFEW - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IOFFEW=IOFFEW+IGP3APAR*IGP3ALEV + + IF (.NOT. PRESENT(PGP)) THEN + ! This is only relevant if we use the split interface (i.e. not PGP) + + IGP2PAR = 0 + IGP3APAR = 0 + IGP3ALEV = 0 + IGP3BPAR = 0 + IGP3BLEV = 0 + IF (PRESENT(PGP2)) THEN + IGP2PAR = UBOUND(PGP2,2) + IF(LSCDERS) IGP2PAR = IGP2PAR/3 + ENDIF + IF (PRESENT(PGP3A)) THEN + IGP3ALEV = UBOUND(PGP3A,2) + IGP3APAR = UBOUND(PGP3A,3) + IF(LSCDERS) IGP3APAR = IGP3APAR/3 + ENDIF + IF (PRESENT(PGP3B)) THEN + IGP3BLEV = UBOUND(PGP3B,2) + IGP3BPAR = UBOUND(PGP3B,3) + IF(LSCDERS) IGP3BPAR = IGP3BPAR/3 + ENDIF + IF (IGP2PAR + IGP3ALEV*IGP3APAR + IGP3BPAR*IGP3BLEV /= KF_SCALARS_G) THEN + PRINT *, IGP2PAR, IGP3APAR, IGP3ALEV, IGP3BPAR, IGP3BLEV + CALL ABORT_TRANS("INCONSISTENCY IN SCALARS") + ENDIF + + ! This is only relevant if we use the split interface (i.e. not PGP) + IUVPAR = 1 + IOFF=1 + IF(LVORGP) THEN + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) + IUVPAR=IUVPAR+1 + IOFF=IOFF+KF_UV_G + ENDIF + + IF(LDIVGP) THEN + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) + IUVPAR=IUVPAR+1 + IOFF=IOFF+KF_UV_G + ENDIF + + ! U + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) + IUVPAR=IUVPAR+1 + IOFF=IOFF+KF_UV_G + + ! V + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) + IUVPAR=IUVPAR+1 + IOFF=IOFF+KF_UV_G + + ! Scalars + ! PGP2 + IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,1) = IGP_OFFSETS_GP2 + IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,2) = (/(J, J=1,IGP2PAR)/) + IOFF=IOFF+IGP2PAR + ! PGP3A + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,1) = IGP_OFFSETS_GP3A + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,2) = (/(1+J/IGP3ALEV, J=0,IGP3APAR*IGP3ALEV-1)/) + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,3) = (/(1+MOD(J,IGP3ALEV), J=0,IGP3APAR*IGP3ALEV-1)/) + IOFF=IOFF+IGP3APAR*IGP3ALEV + ! PGP3B + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,1) = IGP_OFFSETS_GP3B + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,2) = (/(1+J/IGP3BLEV, J=0,IGP3BPAR*IGP3BLEV-1)/) + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,3) = (/(1+MOD(J,IGP3BLEV), J=0,IGP3BPAR*IGP3BLEV-1)/) + IOFF=IOFF+IGP3BPAR*IGP3BLEV + + IF(LSCDERS) THEN + !Scalars NS Derivatives + ! PGP2 + IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,1) = IGP_OFFSETS_GP2 + IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,2) = (/(J+IGP2PAR, J=1,IGP2PAR)/) + IOFF=IOFF+IGP2PAR + ! PGP3A + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,1) = IGP_OFFSETS_GP3A + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,2) = (/(1+IGP3APAR+J/IGP3ALEV, J=0,IGP3APAR*IGP3ALEV-1)/) + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,3) = (/(1+MOD(J,IGP3ALEV), J=0,IGP3APAR*IGP3ALEV-1)/) + IOFF=IOFF+IGP3APAR*IGP3ALEV + ! PGP3B + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,1) = IGP_OFFSETS_GP3B + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,2) = (/(1+IGP3BPAR+J/IGP3BLEV, J=0,IGP3BPAR*IGP3BLEV-1)/) + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,3) = (/(1+MOD(J,IGP3BLEV), J=0,IGP3BPAR*IGP3BLEV-1)/) + IOFF=IOFF+IGP3BPAR*IGP3BLEV + ENDIF + + IF(LUVDER) THEN + ! U Derivative NS + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) + IUVPAR=IUVPAR+1 + IOFF=IOFF+KF_UV_G + + ! V Derivative NS + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR + IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) + IUVPAR=IUVPAR+1 + IOFF=IOFF+KF_UV_G + ENDIF + + IF(LSCDERS) THEN + !Scalars NS Derivatives + ! PGP2 + IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,1) = IGP_OFFSETS_GP2 + IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,2) = (/(J+2*IGP2PAR, J=1,IGP2PAR)/) + IOFF=IOFF+IGP2PAR + ! PGP3A + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,1) = IGP_OFFSETS_GP3A + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,2) = (/(1+2*IGP3APAR+J/IGP3ALEV, J=0,IGP3APAR*IGP3ALEV-1)/) + IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,3) = (/(1+MOD(J,IGP3ALEV), J=0,IGP3APAR*IGP3ALEV-1)/) + IOFF=IOFF+IGP3APAR*IGP3ALEV + ! PGP3B + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,1) = IGP_OFFSETS_GP3B + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,2) = (/(1+2*IGP3BPAR+J/IGP3BLEV, J=0,IGP3BPAR*IGP3BLEV-1)/) + IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,3) = (/(1+MOD(J,IGP3BLEV), J=0,IGP3BPAR*IGP3BLEV-1)/) + IOFF=IOFF+IGP3BPAR*IGP3BLEV + ENDIF ENDIF - ENDIF - - LLGP3B(:) = .FALSE. - IF(LLPGP3B) THEN - IGP3BLEV=UBOUND(PGP3B,2) - IGP3BPAR=UBOUND(PGP3B,3) - IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 - IOFF=IOFF1 - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1 - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IGP3BPAR - IOFF1=IOFF1+IGP3BPAR*IGP3BLEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3BPAR - IOFFNS=IOFFNS+IGP3BPAR*IGP3BLEV - IOFF=IOFFEW - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO + + CALL GSTATS(1806,0) + + ! Prepare receiver arrays + ! find number of fields on a certain V-set + IF(NPRTRV == 1) THEN + ! This is needed because KVSET(JFLD) == -1 if there is only one V-set + IRECV_FIELD_COUNT(1) = KF_GP + ELSE + IRECV_FIELD_COUNT(:) = 0 + DO JFLD=1,KF_GP + IRECV_FIELD_COUNT(IVSET(JFLD)) = IRECV_FIELD_COUNT(IVSET(JFLD)) + 1 ENDDO - IOFFEW=IOFFEW+IGP3BPAR*IGP3BLEV ENDIF - ENDIF - - CALL INIGPTR(IGPTRSEND,IGPTRRECV) - LLDONE = .FALSE. - ITAG = MTAGLG - - INDOFFX = 0 - IBUFLENS = 0 - IBUFLENR = 0 - INRECV = 0 - INSEND = 0 - - DO JROC=1,NPROC - - CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) - ISEND = JROC - ISENT(JROC) = 0 - IRCVD(JROC) = 0 - - ! count up expected number of fields - IPOS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == ISETV .OR. KVSET(JFLD) == -1) IPOS = IPOS+1 + ! find number of grid-points on a certain W-set that overlap with myself + IRECV_WSET_SIZE(:) = 0 + DO ILOCAL_LAT=D%NFRSTLAT(MY_REGION_NS),D%NLSTLAT(MY_REGION_NS) + ILAT_STRIP = ILOCAL_LAT-D%NFRSTLAT(MY_REGION_NS)+D%NPTRFLOFF+1 + IRECV_WSET_SIZE(D%NPROCL(ILOCAL_LAT)) = & + & IRECV_WSET_SIZE(D%NPROCL(ILOCAL_LAT))+D%NONL(ILAT_STRIP,MY_REGION_EW) ENDDO - IRECVTOT(JROC) = IGPTRRECV(ISETW)*IPOS - IF(IRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN - INRECV = INRECV + 1 - JRECV(INRECV)=JROC - ENDIF - - IF( JROC /= MYPROC) IBUFLENR = MAX(IBUFLENR,IRECVTOT(JROC)) - - IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) - ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) - - IPOS = 0 - DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA) - IPOS = IPOS+D%NONL(IGL,ISETB) + ! sum up offsets + IRECV_WSET_OFFSET(1) = 0 + DO JROC=1,NPRTRW + IRECV_WSET_OFFSET(JROC+1)=IRECV_WSET_OFFSET(JROC)+IRECV_WSET_SIZE(JROC) ENDDO - - ISENDTOT(JROC) = IPOS*KF_FS - IF( JROC /= MYPROC) THEN - IBUFLENS = MAX(IBUFLENS,ISENDTOT(JROC)) - IF(ISENDTOT(JROC) > 0) THEN - INSEND = INSEND+1 - JSEND(INSEND)=JROC + DO JROC=1,NPROC + CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) + ! total recv size is # points per field * # fields + IRECVTOT(JROC) = IRECV_WSET_SIZE(ISETW)*IRECV_FIELD_COUNT(ISETV) + ENDDO + + ! Prepare sender arrays + IIN_TO_SEND_BUFR_OFFSET(1) = 0 + DO JROC=1,NPROC + ! Get new offset to my current KINDEX entry + IF (JROC > 1 .AND. KF_FS > 0) THEN + IIN_TO_SEND_BUFR_OFFSET(JROC) = IIN_TO_SEND_BUFR_OFFSET(JROC-1)+ISENDTOT(JROC-1)/KF_FS + ELSEIF (JROC > 1) THEN + IIN_TO_SEND_BUFR_OFFSET(JROC) = IIN_TO_SEND_BUFR_OFFSET(JROC-1) ENDIF - ENDIF - - IF(IPOS > 0) THEN - INDOFF(JROC) = INDOFFX - INDOFFX = INDOFFX+IPOS + + CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) + + ! MAX(Index of first fourier latitude for this W set, first latitude of a senders A set) + ! i.e. we find the overlap between what we have on sender side (others A set) and the receiver + ! (me, the W-set). Ideally those conincide, at least mostly. + IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) + ! MIN(Index of last fourier latitude for this W set, last latitude of a senders A set) + ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) + IPOS = 0 DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA) + ! get from "actual" latitude to the latitude strip offset + IGL = JGL-D%NFRSTLAT(ISETA)+D%NPTRFRSTLAT(ISETA) + ! get from "actual" latitude to the latitude offset IGLL = JGL-D%NPTRLS(MYSETW)+1 - DO JL=D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL),& - &D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL)+D%NONL(IGL,ISETB)-1 + DO JL=1,D%NONL(IGL,ISETB) IPOS = IPOS+1 - KINDEX(IPOS+INDOFF(JROC)) = JL + ! offset to first layer of this gridpoint + IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_OFFSET(JROC)+IPOS,1) = & + & KF_FS*D%NSTAGTF(IGLL)+(D%NSTA(IGL,ISETB)-1)+(JL-1) + ! distance between two layers of this gridpoint + IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_OFFSET(JROC)+IPOS,2) = & + & D%NSTAGTF(IGLL+1)-D%NSTAGTF(IGLL) ENDDO ENDDO + !we always receive the full fourier space + ISENDTOT(JROC) = IPOS*KF_FS + ENDDO + + !$ACC DATA COPYIN(IIN_TO_SEND_BUFR,IGP_OFFSETS) ASYNC(1) + + ACC_POINTERS_CNT = 0 + IF (PRESENT(PGP)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP) + ENDIF + IF (PRESENT(PGPUV)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGPUV) + ENDIF + IF (PRESENT(PGP2)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP2) + ENDIF + IF (PRESENT(PGP3A)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3A) + ENDIF + IF (PRESENT(PGP3B)) THEN + ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 + ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3B) ENDIF - ENDDO - - ISENDCOUNT=0 - IRECVCOUNT=0 - DO J=1,NPROC - ISENDCOUNT=MAX(ISENDCOUNT,ISENDTOT(J)) - IRECVCOUNT=MAX(IRECVCOUNT,IRECVTOT(J)) - ENDDO - IF (IBUFLENS > 0) ALLOCATE(ZCOMBUFS(1:ISENDCOUNT,INSEND)) - IF (IBUFLENR > 0) ALLOCATE(ZCOMBUFR(1:IRECVCOUNT,INRECV)) - !$ACC DATA IF(IBUFLENS > 0) CREATE(ZCOMBUFS) - !$ACC DATA IF(IBUFLENR > 0) CREATE(ZCOMBUFR) - - !$ACC KERNELS DEFAULT(NONE) - IF (IBUFLENS > 0) ZCOMBUFS(:,:) = 0 - IF (IBUFLENR > 0) ZCOMBUFR(:,:) = 0 - !$ACC END KERNELS - - !$ACC DATA & - !$ACC PRESENT(PGLAT) & - !$ACC COPYIN(IGPTRSEND,INDOFF,KINDEX, LLUV,LLGP2,LLGP3A,LLGP3B,KPTRGP) - !$ACC DATA IF(PRESENT(PGP)) COPYOUT(PGP) - !$ACC DATA IF(PRESENT(PGPUV)) COPYOUT(PGPUV) COPYIN(IUVLEVS,IUVPARS) - !$ACC DATA IF(PRESENT(PGP2)) COPYOUT(PGP2) COPYIN(IGP2PARS) - !$ACC DATA IF(PRESENT(PGP3A)) COPYOUT(PGP3A) COPYIN(IGP3APARS,IGP3ALEVS) - !$ACC DATA IF(PRESENT(PGP3B)) COPYOUT(PGP3B) COPYIN(IGP3BPARS, IGP3BLEVS) - - CALL GSTATS(1806,1) - - ! Copy local contribution - IF( IRECVTOT(MYPROC) > 0 )THEN - IFLDS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == MYSETV .OR. KVSET(JFLD) == -1) THEN - IFLDS = IFLDS+1 - IF(LLINDER) THEN - IFLDOFF(IFLDS) = KPTRGP(JFLD) - ELSE - IFLDOFF(IFLDS) = JFLD + IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_CREATE(ACC_POINTERS(1:ACC_POINTERS_CNT),STREAM=1_ACC_HANDLE_KIND) + !$ACC DATA IF(PRESENT(PGP)) PRESENT(PGP) ASYNC(1) + !$ACC DATA IF(PRESENT(PGPUV)) PRESENT(PGPUV) ASYNC(1) + !$ACC DATA IF(PRESENT(PGP2)) PRESENT(PGP2) ASYNC(1) + !$ACC DATA IF(PRESENT(PGP3A)) PRESENT(PGP3A) ASYNC(1) + !$ACC DATA IF(PRESENT(PGP3B)) PRESENT(PGP3B) ASYNC(1) + + ! Present until self contribution and packing are done + !$ACC DATA PRESENT(PREEL_REAL) + CALL GSTATS(1806,1) + + ! Copy local contribution + IF(ISENDTOT(MYPROC) > 0) THEN + ! I have to send something to myself... + + ! Input is KF_GP fields. We find the resulting KF_FS fields. + IFLDS = 0 + DO JFLD=1,KF_GP + IF(IVSET(JFLD) == MYSETV .OR. IVSET(JFLD) == -1) THEN + IFLDS = IFLDS+1 + IF(PRESENT(KPTRGP)) THEN + IFLDA(IFLDS) = KPTRGP(JFLD) + ELSE + IFLDA(IFLDS) = JFLD + ENDIF ENDIF - ENDIF - ENDDO - - IPOS=0 - JK_MAX=0 - DO JBLK=1,NGPBLKS - IGPTROFF(JBLK)=IPOS - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,MYSETW) - IPOS=IPOS+ILAST-IFIRST+1 - IF (JK_MAX<(ILAST-IFIRST+1)) JK_MAX = (ILAST-IFIRST+1) - ENDIF - ENDDO - - CALL GSTATS(1604,0) - - IF (LLPGPONLY) THEN - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IPOS,IFIRST,ILAST,IFLD,JK) & - !$ACC COPYIN(IGPTROFF,IFLDOFF,JK_MAX) COLLAPSE(3) - DO JBLK=1,NGPBLKS - DO JFLD=1,IFLDS - DO JKL=1,JK_MAX - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - ILAST = IGPTRSEND(2,JBLK,MYSETW) - JK = JKL+IFIRST-1 - IF(IFIRST>0 .AND. JK<=ILAST) THEN - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JKL - IF(LLINDER) THEN - IFLD = KPTRGP(JFLD) - PGP(JK,IFLD,JBLK) = PGLAT(JFLD,KINDEX(IPOS)) - ELSE - IFLD = IFLDOFF(JFLD) - PGP(JK,IFLD,JBLK) = PGLAT(JFLD,KINDEX(IPOS)) - ENDIF - ENDIF + ENDDO + + !$ACC DATA COPYIN(IFLDA(1:IFLDS)) ASYNC(1) + + CALL GSTATS(1604,0) + + IRECV_WSET_OFFSET_V = IRECV_WSET_OFFSET(MYSETW) + IRECV_WSET_SIZE_V = IRECV_WSET_SIZE(MYSETW) + IIN_TO_SEND_BUFR_V = IIN_TO_SEND_BUFR_OFFSET(MYPROC) + IF (PRESENT(PGP)) THEN + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS) ASYNC(1) + DO JFLD=1,KF_FS + DO JL=1,IRECV_WSET_SIZE_V + JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD = IFLDA(JFLD) + IPOS = IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,1)+ & + & (JFLD-1)*IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,2)+1 + PGP(JK,IFLD,JBLK) = PREEL_REAL(IPOS) ENDDO ENDDO - ENDDO - ELSE - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IPOS,IFIRST,ILAST,IFLD,JK) & - !$ACC COPYIN(IGPTROFF,IFLDOFF,JK_MAX) COLLAPSE(3) - DO JBLK=1,NGPBLKS - DO JFLD=1,IFLDS - DO JKL=1,JK_MAX - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - ILAST = IGPTRSEND(2,JBLK,MYSETW) - JK = JKL+IFIRST-1 - IF(IFIRST>0 .AND. JK<=ILAST) THEN - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JKL - IFLD = IFLDOFF(JFLD) - IF(LLUV(IFLD)) THEN - PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) = PGLAT(JFLD,KINDEX(IPOS)) - ELSEIF(LLGP2(IFLD)) THEN - PGP2(JK,IGP2PARS(IFLD),JBLK)=PGLAT(JFLD,KINDEX(IPOS)) - ELSEIF(LLGP3A(IFLD)) THEN - PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK)=PGLAT(JFLD,KINDEX(IPOS)) - ELSEIF(LLGP3B(IFLD)) THEN - PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK)=PGLAT(JFLD,KINDEX(IPOS)) - ENDIF + ELSE + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS) ASYNC(1) + DO JFLD=1,KF_FS + DO JL=1,IRECV_WSET_SIZE_V + JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD = IFLDA(JFLD) + IPOS = IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,1)+ & + & (JFLD-1)*IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,2)+1 + IF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_UV) THEN + PGPUV(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = PREEL_REAL(IPOS) + ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP2) THEN + PGP2(JK,IGP_OFFSETS(IFLD,2),JBLK)=PREEL_REAL(IPOS) + ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3A) THEN + PGP3A(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = PREEL_REAL(IPOS) + ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3B) THEN + PGP3B(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = PREEL_REAL(IPOS) ENDIF ENDDO ENDDO - ENDDO + ENDIF + CALL GSTATS(1604,1) + + !$ACC END DATA + ENDIF - CALL GSTATS(1604,1) - - ENDIF - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - ! - ! loop over the number of processors we need to communicate with. - ! NOT MYPROC - ! - ! Pack loop......................................................... - - CALL GSTATS(1605,0) - - DO INS=1,INSEND - ISEND=JSEND(INS) - ILEN = ISENDTOT(ISEND)/KF_FS - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(II) COPYIN(ILEN) COLLAPSE(2) - DO JL=1,ILEN - DO JFLD=1,KF_FS - II = KINDEX(INDOFF(ISEND)+JL) - ZCOMBUFS((JFLD-1)*ILEN+JL,INS) = PGLAT(JFLD,II) - ENDDO - ENDDO - ICOMS_KFFS(INS) = KF_FS - ENDDO - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - !IF(MPL_MYRANK==1) WRITE(*,*) "packing (trltog) in sec: ", Tc - #endif - - CALL GSTATS(1605,1) - - IR=0 - IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',0,ZHOOK_HANDLE_BAR) - CALL GSTATS_BARRIER(762) - IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',1,ZHOOK_HANDLE_BAR) - CALL GSTATS(805,0) - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - - IF (LSYNC_TRANS) THEN - CALL GSTATS(422,0) - CALL MPL_BARRIER(CDSTRING='TRLTOG BARRIER') - CALL GSTATS(422,1) - ENDIF - CALL GSTATS(412,0) - - !...Receive loop......................................................... - !$ACC HOST_DATA USE_DEVICE(ZCOMBUFS,ZCOMBUFR) - DO INR=1,INRECV - IR=IR+1 - IRECV=JRECV(INR) - CALL MPI_IRECV(ZCOMBUFR(1:IRECVTOT(IRECV),INR), & - & IRECVTOT(IRECV), & - & TRLTOG_DTYPE,NPRCIDS(IRECV)-1, & - & ITAG, MPL_COMM_OML(OML_MY_THREAD()), IREQ(IR), & - & IERROR ) - IR=IR+1 - CALL MPI_IRECV(ICOMR_KFFS(INR), 1, & - & MPI_INTEGER,NPRCIDS(IRECV)-1, & - & ITAG, MPL_COMM_OML(OML_MY_THREAD()), IREQ(IR), & - & IERROR ) - ENDDO - - !...Send loop......................................................... - DO INS=1,INSEND - IR=IR+1 - ISEND=JSEND(INS) - CALL MPI_ISEND(ZCOMBUFS(1:ISENDTOT(ISEND),INS),& - & ISENDTOT(ISEND), & - & TRLTOG_DTYPE, NPRCIDS(ISEND)-1,ITAG, & - & MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR), & - & IERROR) - IR=IR+1 - CALL MPI_ISEND(ICOMS_KFFS(INS),1, & - & MPI_INTEGER, NPRCIDS(ISEND)-1,ITAG, & - & MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR), & - & IERROR) - ENDDO - !$ACC END HOST_DATA - - IF(IR > 0) THEN - CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & - & CDSTRING='TRLTOG_CUDAAWARE: WAIT FOR SENDS AND RECEIVES') - ENDIF - - CALL GSTATS(412,1) - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - !IF(MPL_MYRANK==1) WRITE(*,*) "CUDA-aware isend/irecv (trltog) in sec: ", Tc - #endif - - CALL GSTATS(805,1) - CALL GSTATS_BARRIER2(762) - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - ! Unpack loop......................................................... - - CALL GSTATS(1606,0) - DO INR=1,INRECV - IRECV=JRECV(INR) - CALL PE2SET(IRECV,ISETA,ISETB,ISETW,ISETV) - IRECVSET = ISETV -! IRECV_FLD_START = 1 !! INT(ZCOMBUFR(-1,INR),KIND=JPIM) !! is this always 1 ? - IRECV_FLD_END = ICOMR_KFFS(INR) - IFLD = 0 - IPOS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == IRECVSET .OR. KVSET(JFLD) == -1 ) THEN - IFLD = IFLD+1 - IFLDA(IFLD)=JFLD + ! Figure out processes that send or recv something + ISEND_COUNTS = 0 + IRECV_COUNTS = 0 + DO JROC=1,NPROC + IF( JROC /= MYPROC) THEN + IF(IRECVTOT(JROC) > 0) THEN + ! I have to recv something, so let me store that + IRECV_COUNTS = IRECV_COUNTS + 1 + IRECV_TO_PROC(IRECV_COUNTS)=JROC ENDIF - ENDDO - - JK_MAX=0 - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,ISETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,ISETW) - JPOS(JBLK)=IPOS - IPOS=IPOS+(ILAST-IFIRST+1) - IF (JK_MAX<(ILAST-IFIRST+1)) JK_MAX = (ILAST-IFIRST+1) + IF(ISENDTOT(JROC) > 0) THEN + ! I have to send something, so let me store that + ISEND_COUNTS = ISEND_COUNTS+1 + ISEND_TO_PROC(ISEND_COUNTS)=JROC ENDIF - ENDDO - - !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IFIRST,ILAST,JI,JK,IFLDT) & - !$ACC COPYIN(INR,KF_FS,IPOS,JPOS,IFLD,IFLDA,JK_MAX,IRECV_FLD_END) COLLAPSE(3) - DO JBLK=1,NGPBLKS - DO JJ=1,IRECV_FLD_END - DO JKL=1,JK_MAX - IFLDT=IFLDA(JJ) - IFIRST = IGPTRSEND(1,JBLK,ISETW) - ILAST = IGPTRSEND(2,JBLK,ISETW) - JK = JKL+IFIRST-1 - JI=(JJ-1)*IPOS+JPOS(JBLK)+JKL - IF(IFIRST > 0 .AND. JK<=ILAST) THEN - IF(LLINDER) THEN - PGP(JK,KPTRGP(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ELSEIF(LLPGPONLY) THEN - PGP(JK,IFLDT,JBLK) = ZCOMBUFR(JI,INR) - ELSEIF(LLUV(IFLDT)) THEN - PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ELSEIF(LLGP2(IFLDT)) THEN - PGP2(JK,IGP2PARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ELSEIF(LLGP3A(IFLDT)) THEN - PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ELSEIF(LLGP3B(IFLDT)) THEN - PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - + ENDIF ENDDO - CALL GSTATS(431,0) - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - !$ACC END DATA - - !$ACC END DATA !! CREATE ZCOMBUFR - !$ACC END DATA !! CREATE ZCOMBUFS - CALL GSTATS(431,1) - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - !IF(MPL_MYRANK==1) WRITE(*,*) "unpacking (trltog) in sec: ", Tc - #endif - - CALL GSTATS(1606,1) - IF (IBUFLENS > 0) DEALLOCATE(ZCOMBUFS) - IF (IBUFLENR > 0) DEALLOCATE(ZCOMBUFR) - - IF (LHOOK) CALL DR_HOOK('TRLTOG',1,ZHOOK_HANDLE) - - END SUBROUTINE TRLTOG_CUDAAWARE - - SUBROUTINE TRLTOG(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,& - &PGP,PGPUV,PGP3A,PGP3B,PGP2) - - !**** *trltog * - transposition of grid point data from latitudinal - ! to column structure. This takes place between inverse - ! FFT and grid point calculations. - ! TRLTOG is the inverse of TRGTOL - - ! Purpose. - ! -------- - - - !** Interface. - ! ---------- - ! *call* *trltog(...) - - ! Explicit arguments : - ! -------------------- - ! PGLAT - Latitudinal data ready for direct FFT (input) - ! PGP - Blocked grid point data (output) - ! KVSET - "v-set" for each field (input) - - ! Implicit arguments : - ! -------------------- - - ! Method. - ! ------- - ! See documentation - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! MPP Group *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 95-10-01 - ! D.Dent : 97-08-04 Reorganisation to allow NPRTRV - ! to differ from NPRGPEW - ! =99-03-29= Mats Hamrud and Deborah Salmond - ! JUMP in FFT's changed to 1 - ! INDEX introduced and ZCOMBUF not used for same PE - ! 01-11-23 Deborah Salmond and John Hague - ! LIMP_NOOLAP Option for non-overlapping message passing - ! and buffer packing - ! 01-12-18 Peter Towers - ! Improved vector performance of LTOG_PACK,LTOG_UNPACK - ! 03-0-02 G. Radnoti: Call barrier always when nproc>1 - ! 08-01-01 G.Mozdzynski: cleanup - ! 09-01-02 G.Mozdzynski: use non-blocking recv and send - ! ------------------------------------------------------------------ - - - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB , JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_MYRANK - - USE TPM_GEN ,ONLY : NOUT - USE TPM_DISTR ,ONLY : D, MYSETV, MYSETW, MTAGLG, & - & NPRCIDS, NPRTRNS, MYPROC, NPROC - USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, NGPBLKS - - USE INIGPTR_MOD ,ONLY : INIGPTR - USE PE2SET_MOD ,ONLY : PE2SET - !USE MYSENDSET_MOD - !USE MYRECVSET_MOD - USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS - ! - USE MPI - - IMPLICIT NONE - - - REAL(KIND=JPRBT), INTENT(IN) :: PGLAT(:,:) - INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(:) - INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP - INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G - INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) - REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) - - ! LOCAL VARIABLES - - REAL(KIND=JPRBT),ALLOCATABLE :: ZCOMBUFS(:,:),ZCOMBUFR(:,:) - REAL(KIND=JPRBT) :: ZDUM(2) - - INTEGER(KIND=JPIM) :: ISENT (NPROC) - INTEGER(KIND=JPIM) :: IRCVD (NPROC) - INTEGER(KIND=JPIM) :: ISENDTOT (NPROC) - INTEGER(KIND=JPIM) :: IRECVTOT (NPROC) - INTEGER(KIND=JPIM) :: IREQ (NPROC*2) - INTEGER(KIND=JPIM) :: JSEND (NPROC) - INTEGER(KIND=JPIM) :: JRECV (NPROC) - - INTEGER(KIND=JPIM) :: IFIRST, IFIRSTLAT, IFLD, IGL, IGLL,& - &ILAST, ILASTLAT, IPOS, ISETA, & - &ISETB, IRECV, IRECVSET, & - &ISETV, ISEND, ITAG, JBLK, JFLD, & - &JGL, JK, JL, JLOOP, ISETW, IFLDS, IPROC,JROC, & - &INRECV, INSEND,INR,INS,IR - INTEGER(KIND=JPIM) :: II,INDOFFX,ILEN,IBUFLENS,IBUFLENR - - LOGICAL :: LLPGPUV,LLPGP3A,LLPGP3B,LLPGP2,LLPGPONLY - LOGICAL :: LLUV(KF_GP),LLGP2(KF_GP),LLGP3A(KF_GP),LLGP3B(KF_GP) - LOGICAL :: LLDONE, LLINDER - INTEGER(KIND=JPIM) :: IUVLEVS(KF_GP),IUVPARS(KF_GP),IGP2PARS(KF_GP) - INTEGER(KIND=JPIM) :: IGP3APARS(KF_GP),IGP3ALEVS(KF_GP),IGP3BPARS(KF_GP),IGP3BLEVS(KF_GP) - INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF - INTEGER(KIND=JPIM) :: IOFF,IOFF1,IOFFNS,IOFFEW,J1,J2 - INTEGER(KIND=JPIM) :: INDEX(D%NLENGTF),INDOFF(NPROC),IFLDOFF(KF_GP) - INTEGER(KIND=JPIM) :: IRECV_FLD_START,IRECV_FLD_END - INTEGER(KIND=JPIM) :: ISEND_FLD_START(NPROC),ISEND_FLD_END - INTEGER(KIND=JPIM) :: INUMFLDS - INTEGER(KIND=JPIM) :: IGPTRSEND(2,NGPBLKS,NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTRRECV(NPRTRNS) - INTEGER(KIND=JPIM) :: IGPTROFF(NGPBLKS) - - ! INTEGER FUNCTIONS - INTEGER(KIND=JPIM) :: ISENDCOUNT,IRECVCOUNT,J - INTEGER(KIND=JPIM) :: JPOS(NGPBLKS),IFLDA(KF_GP),JI,JJ - INTEGER(KIND=JPIM) :: IFLDT - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR - - INTEGER(KIND=JPIM) :: IERROR - - REAL(KIND=JPRBT) :: TIMEF, tc - - ! ------------------------------------------------------------------ - - !* 0. Some initializations - ! -------------------- - IF (LHOOK) CALL DR_HOOK('TRLTOG',0,ZHOOK_HANDLE) - - - CALL GSTATS(1806,0) - - LLINDER = .FALSE. - LLPGPUV = .FALSE. - LLPGP3A = .FALSE. - LLPGP3B = .FALSE. - LLPGP2 = .FALSE. - LLPGPONLY = .FALSE. - IF(PRESENT(KPTRGP)) LLINDER = .TRUE. - IF(PRESENT(PGP)) LLPGPONLY=.TRUE. - IF(PRESENT(PGPUV)) LLPGPUV=.TRUE. - IF(PRESENT(PGP3A)) LLPGP3A=.TRUE. - IF(PRESENT(PGP3B)) LLPGP3B=.TRUE. - IF(PRESENT(PGP2)) LLPGP2=.TRUE. - - IUVPAR=0 - IUVLEV=0 - IOFF1=0 - IOFFNS=KF_SCALARS_G - IOFFEW=2*KF_SCALARS_G - - LLUV(:) = .FALSE. - IF (LLPGPUV) THEN - IOFF=0 - IUVLEV=UBOUND(PGPUV,2) - IF(LVORGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV - ENDIF - IF(LDIVGP) THEN - IUVPAR=IUVPAR+1 - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR - LLUV(IOFF+J)=.TRUE. - ENDDO - IOFF=IOFF+IUVLEV - ENDIF - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 + ALLOCATE(ICOMBUFS_OFFSET(ISEND_COUNTS+1)) + ICOMBUFS_OFFSET(1) = 0 + DO JROC=1,ISEND_COUNTS + ICOMBUFS_OFFSET(JROC+1) = ICOMBUFS_OFFSET(JROC) + ISENDTOT(ISEND_TO_PROC(JROC)) ENDDO - IUVPAR=IUVPAR+2 - LLUV(IOFF+1:IOFF+2*IUVLEV)=.TRUE. - IOFF=IOFF+2*IUVLEV - IOFF1=IOFF - IOFFNS=IOFFNS+IOFF - IOFFEW=IOFFEW+IOFF - - IOFF=IUVPAR*IUVLEV+KF_SCALARS_G - IF(LUVDER) THEN - IF(LSCDERS) IOFF=IOFF+KF_SCALARS_G - DO J=1,IUVLEV - IUVLEVS(IOFF+J)=J - IUVPARS(IOFF+J)=IUVPAR+1 - LLUV(IOFF+J)=.TRUE. - IUVLEVS(IOFF+J+IUVLEV)=J - IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 - LLUV(IOFF+J+IUVLEV)=.TRUE. - ENDDO - IUVPAR=IUVPAR+2 - IOFF=IOFF+2*IUVLEV - IOFFEW=IOFFEW+2*IUVLEV - ENDIF - ENDIF - - LLGP2(:)=.FALSE. - IF(LLPGP2) THEN - IOFF=IOFF1 - IGP2PAR=UBOUND(PGP2,2) - IF(LSCDERS) IGP2PAR=IGP2PAR/3 - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J + ALLOCATE(ICOMBUFR_OFFSET(IRECV_COUNTS+1)) + ICOMBUFR_OFFSET(1) = 0 + DO JROC=1,IRECV_COUNTS + ICOMBUFR_OFFSET(JROC+1) = ICOMBUFR_OFFSET(JROC) + IRECVTOT(IRECV_TO_PROC(JROC)) ENDDO - IOFF1=IOFF1+IGP2PAR - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+IGP2PAR - ENDDO - IOFFNS=IOFF+IGP2PAR - IOFF=IOFFEW - DO J=1,IGP2PAR - LLGP2(J+IOFF) = .TRUE. - IGP2PARS(J+IOFF)=J+2*IGP2PAR - ENDDO - IOFFEW=IOFF+IGP2PAR + + IF (IRECV_COUNTS > 0) THEN + CALL ASSIGN_PTR(ZCOMBUFR, GET_ALLOCATION(ALLOCATOR, HTRLTOG%HCOMBUFR_AND_COMBUFS),& + & 1_C_SIZE_T, ICOMBUFR_OFFSET(IRECV_COUNTS+1)*SIZEOF(ZCOMBUFR(1))) ENDIF - ENDIF - - LLGP3A(:) = .FALSE. - IF(LLPGP3A) THEN - IGP3ALEV=UBOUND(PGP3A,2) - IGP3APAR=UBOUND(PGP3A,3) - IF(LSCDERS) IGP3APAR=IGP3APAR/3 - IOFF=IOFF1 - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1 - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IGP3APAR - IOFF1=IOFF1+IGP3APAR*IGP3ALEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3APAR - IOFFNS=IOFFNS+IGP3APAR*IGP3ALEV - IOFF=IOFFEW - DO J1=1,IGP3APAR - DO J2=1,IGP3ALEV - LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. - IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF - IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 - ENDDO - ENDDO - IOFFEW=IOFFEW+IGP3APAR*IGP3ALEV + IF (ISEND_COUNTS > 0) THEN + CALL ASSIGN_PTR(ZCOMBUFS, GET_ALLOCATION(ALLOCATOR, HTRLTOG%HCOMBUFR_AND_COMBUFS),& + & ALIGN(KF_GP*D%NGPTOT*SIZEOF(ZCOMBUFR(1)),128)+1, & + & ICOMBUFS_OFFSET(ISEND_COUNTS+1)*SIZEOF(ZCOMBUFS(1))) ENDIF - ENDIF - - LLGP3B(:) = .FALSE. - IF(LLPGP3B) THEN - IGP3BLEV=UBOUND(PGP3B,2) - IGP3BPAR=UBOUND(PGP3B,3) - IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 - IOFF=IOFF1 - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1 - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IGP3BPAR - IOFF1=IOFF1+IGP3BPAR*IGP3BLEV - IF(LSCDERS) THEN - IOFF=IOFFNS - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 - ENDDO - ENDDO - IPAROFF=IPAROFF+IGP3BPAR - IOFFNS=IOFFNS+IGP3BPAR*IGP3BLEV - IOFF=IOFFEW - DO J1=1,IGP3BPAR - DO J2=1,IGP3BLEV - LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. - IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF - IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 + + !$ACC DATA PRESENT(ZCOMBUFS) + CALL GSTATS(1605,0) + DO INS=1,ISEND_COUNTS + IPROC = ISEND_TO_PROC(INS) + ILEN = ISENDTOT(IPROC)/KF_FS + IIN_TO_SEND_BUFR_V = IIN_TO_SEND_BUFR_OFFSET(IPROC) + ICOMBUFS_OFFSET_V = ICOMBUFS_OFFSET(INS) + !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IPOS) COLLAPSE(2) ASYNC(1) + DO JFLD=1,KF_FS + DO JL=1,ILEN + IPOS = IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,1)+ & + & (JFLD-1)*IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,2)+1 + ZCOMBUFS(ICOMBUFS_OFFSET_V+(JFLD-1)*ILEN+JL) = PREEL_REAL(IPOS) ENDDO ENDDO - IOFFEW=IOFFEW+IGP3BPAR*IGP3BLEV - ENDIF - ENDIF - - CALL INIGPTR(IGPTRSEND,IGPTRRECV) - LLDONE = .FALSE. - ITAG = MTAGLG - - INDOFFX = 0 - IBUFLENS = 0 - IBUFLENR = 0 - INRECV = 0 - INSEND = 0 - - DO JROC=1,NPROC - - CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) - ISEND = JROC - ISENT(JROC) = 0 - IRCVD(JROC) = 0 - - ! count up expected number of fields - IPOS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == ISETV .OR. KVSET(JFLD) == -1) IPOS = IPOS+1 ENDDO - IRECVTOT(JROC) = IGPTRRECV(ISETW)*IPOS - IF(IRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN - INRECV = INRECV + 1 - JRECV(INRECV)=JROC + CALL GSTATS(1605,1) + !$ACC END DATA ! ZCOMBUFS + + !$ACC END DATA ! PREEL_REAL + + !$ACC WAIT(1) + + CALL GSTATS(805,0) + + IF (LSYNC_TRANS) THEN + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) ENDIF - - IF( JROC /= MYPROC) IBUFLENR = MAX(IBUFLENR,IRECVTOT(JROC)) - - IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) - ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) - - IPOS = 0 - DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA) - IPOS = IPOS+D%NONL(IGL,ISETB) + CALL GSTATS(421,0) + + IR=0 + !...Receive loop......................................................... + !$ACC HOST_DATA USE_DEVICE(ZCOMBUFS,ZCOMBUFR) + DO INR=1,IRECV_COUNTS + IR=IR+1 + IRECV=IRECV_TO_PROC(INR) + CALL MPI_IRECV(ZCOMBUFR(ICOMBUFR_OFFSET(INR)+1:ICOMBUFR_OFFSET(INR+1)), & + & IRECVTOT(IRECV), & + & TRLTOG_DTYPE,NPRCIDS(IRECV)-1, & + & MTAGLG, MPL_COMM_OML(OML_MY_THREAD()), IREQ(IR), & + & IERROR ) ENDDO - - ISENDTOT(JROC) = IPOS*KF_FS - IF( JROC /= MYPROC) THEN - IBUFLENS = MAX(IBUFLENS,ISENDTOT(JROC)) - IF(ISENDTOT(JROC) > 0) THEN - INSEND = INSEND+1 - JSEND(INSEND)=JROC - ENDIF + + !...Send loop......................................................... + DO INS=1,ISEND_COUNTS + IR=IR+1 + ISEND=ISEND_TO_PROC(INS) + CALL MPI_ISEND(ZCOMBUFS(ICOMBUFS_OFFSET(INS)+1:ICOMBUFS_OFFSET(INS+1)),ISENDTOT(ISEND), & + & TRLTOG_DTYPE, NPRCIDS(ISEND)-1,MTAGLG,MPL_COMM_OML(OML_MY_THREAD()),IREQ(IR),IERROR) + ENDDO + !$ACC END HOST_DATA + + IF(IR > 0) THEN + CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & + & CDSTRING='TRLTOG_CUDAAWARE: WAIT FOR SENDS AND RECEIVES') ENDIF - - IF(IPOS > 0) THEN - INDOFF(JROC) = INDOFFX - INDOFFX = INDOFFX+IPOS - IPOS = 0 - DO JGL=IFIRSTLAT,ILASTLAT - IGL = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA) - IGLL = JGL-D%NPTRLS(MYSETW)+1 - DO JL=D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL),& - &D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL)+D%NONL(IGL,ISETB)-1 - IPOS = IPOS+1 - INDEX(IPOS+INDOFF(JROC)) = JL - ENDDO - ENDDO + + IF (LSYNC_TRANS) THEN + CALL GSTATS(441,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(441,1) ENDIF - ENDDO - - ISENDCOUNT=0 - IRECVCOUNT=0 - DO J=1,NPROC - ISENDCOUNT=MAX(ISENDCOUNT,ISENDTOT(J)) - IRECVCOUNT=MAX(IRECVCOUNT,IRECVTOT(J)) - ENDDO - IF (IBUFLENS > 0) ALLOCATE(ZCOMBUFS(-1:ISENDCOUNT,INSEND)) - IF (IBUFLENR > 0) ALLOCATE(ZCOMBUFR(-1:IRECVCOUNT,INRECV)) - - CALL GSTATS(1806,1) - - - ! Copy local contribution - IF( IRECVTOT(MYPROC) > 0 )THEN - IFLDS = 0 - DO JFLD=1,KF_GP - IF(KVSET(JFLD) == MYSETV .OR. KVSET(JFLD) == -1) THEN - IFLDS = IFLDS+1 - IF(LLINDER) THEN - IFLDOFF(IFLDS) = KPTRGP(JFLD) - ELSE - IFLDOFF(IFLDS) = JFLD - ENDIF - ENDIF - ENDDO - - IPOS=0 - DO JBLK=1,NGPBLKS - IGPTROFF(JBLK)=IPOS - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,MYSETW) - IPOS=IPOS+ILAST-IFIRST+1 - ENDIF - ENDDO - - CALL GSTATS(1604,0) - #ifdef NECSX - !$OMP PARALLEL DO SCHEDULE(DYNAMIC) PRIVATE(JFLD,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) - #else - !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) - #endif - - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,MYSETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,MYSETW) - IF(LLPGPONLY) THEN - IF(LLINDER) THEN - DO JFLD=1,IFLDS - IFLD = KPTRGP(JFLD) - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP(JK,IFLD,JBLK) = PGLAT(JFLD,INDEX(IPOS)) - ENDDO - ENDDO - ELSE - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP(JK,IFLD,JBLK) = PGLAT(JFLD,INDEX(IPOS)) - ENDDO - ENDDO - ENDIF - ELSE - DO JFLD=1,IFLDS - IFLD = IFLDOFF(JFLD) - IF(LLUV(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) = PGLAT(JFLD,INDEX(IPOS)) - ENDDO - ELSEIF(LLGP2(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP2(JK,IGP2PARS(IFLD),JBLK)=PGLAT(JFLD,INDEX(IPOS)) - ENDDO - ELSEIF(LLGP3A(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK)=PGLAT(JFLD,INDEX(IPOS)) - ENDDO - ELSEIF(LLGP3B(IFLD)) THEN - DO JK=IFIRST,ILAST - IPOS = INDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 - PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK)=PGLAT(JFLD,INDEX(IPOS)) - ENDDO - ELSE - WRITE(NOUT,*)'TRLTOG_MOD: ERROR',JFLD,IFLD - CALL ABORT_TRANS('TRLTOG_MOD: ERROR') - ENDIF - ENDDO - ENDIF - ENDIF - ENDDO - !$OMP END PARALLEL DO - CALL GSTATS(1604,1) - - ENDIF - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - ! - ! loop over the number of processors we need to communicate with. - ! NOT MYPROC - ! - ! Pack loop......................................................... - - CALL GSTATS(1605,0) - - !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JL,II,JFLD,INS,ISEND,ILEN,ISEND_FLD_END) - DO INS=1,INSEND - ISEND=JSEND(INS) - ISEND_FLD_START(ISEND)= 1 - ILEN = ISENDTOT(ISEND)/KF_FS - ISEND_FLD_END = KF_FS - #ifdef NECSX - DO JFLD=ISEND_FLD_START(ISEND),ISEND_FLD_END - DO JL=1,ILEN - II = INDEX(INDOFF(ISEND)+JL) - #else - DO JL=1,ILEN - II = INDEX(INDOFF(ISEND)+JL) - DO JFLD=ISEND_FLD_START(ISEND),ISEND_FLD_END - #endif - ZCOMBUFS((JFLD-ISEND_FLD_START(ISEND))*ILEN+JL,INS) = PGLAT(JFLD,II) - ENDDO - ENDDO - ZCOMBUFS(-1,INS) = 1 - ZCOMBUFS(0,INS) = KF_FS - ENDDO - !$OMP END PARALLEL DO - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - !IF(MPL_MYRANK==1) WRITE(*,*) "packing (trltog) in sec: ", Tc - #endif - - CALL GSTATS(1605,1) - - IR=0 - IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',0,ZHOOK_HANDLE_BAR) - CALL GSTATS_BARRIER(762) - IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',1,ZHOOK_HANDLE_BAR) - CALL GSTATS(805,0) - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - !...Receive loop......................................................... - DO INR=1,INRECV - IR=IR+1 - IRECV=JRECV(INR) - CALL MPL_RECV(ZCOMBUFR(-1:IRECVTOT(IRECV),INR), & - & KSOURCE=NPRCIDS(IRECV), & - & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), & - & KTAG=ITAG,CDSTRING='TRLTOG:' ) - ENDDO - - !...Send loop......................................................... - DO INS=1,INSEND - IR=IR+1 - ISEND=JSEND(INS) - CALL MPL_SEND(ZCOMBUFS(-1:ISENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),& - & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), & - & KTAG=ITAG,CDSTRING='TRLTOG:') - ENDDO - - IF(IR > 0) THEN - CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & - & CDSTRING='TRLTOG: WAIT FOR SENDS AND RECEIVES') - ENDIF - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - !IF(MPL_MYRANK==1) WRITE(*,*) "non-CUDA-aware isend/irecv (trltog) in sec: ", Tc - #endif - - CALL GSTATS(805,1) - CALL GSTATS_BARRIER2(762) - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=TIMEF() - #endif - ! Unpack loop......................................................... - - CALL GSTATS(1606,0) - !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(IFLDT,JBLK,IFIRST,ILAST,JK,& - !$OMP& JJ,JI,JPOS,INR,IRECV,IRECVSET,IRECV_FLD_START,IRECV_FLD_END,IPOS,& - !$OMP& ISETA,ISETB,ISETW,ISETV,JFLD,IFLD,IFLDA) - DO INR=1,INRECV - IRECV=JRECV(INR) + CALL GSTATS(421,1) + + !$ACC DATA PRESENT(ZCOMBUFR) + CALL GSTATS(805,1) + + ! Unpack loop......................................................... + + CALL GSTATS(1606,0) + DO INR=1,IRECV_COUNTS + IRECV=IRECV_TO_PROC(INR) CALL PE2SET(IRECV,ISETA,ISETB,ISETW,ISETV) - IRECVSET = ISETV - IRECV_FLD_START = ZCOMBUFR(-1,INR) - IRECV_FLD_END = ZCOMBUFR(0,INR) - IFLD = 0 - IPOS = 0 + + IRECV_FIELD_COUNT_V = IRECV_FIELD_COUNT(ISETV) + ICOMBUFR_OFFSET_V = ICOMBUFR_OFFSET(INR) + + IFLDS = 0 DO JFLD=1,KF_GP - IF(KVSET(JFLD) == IRECVSET .OR. KVSET(JFLD) == -1 ) THEN - IFLD = IFLD+1 - IFLDA(IFLD)=JFLD - ENDIF - ENDDO - - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,ISETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,ISETW) - JPOS(JBLK)=IPOS - IPOS=IPOS+(ILAST-IFIRST+1) + IF(IVSET(JFLD) == ISETV .OR. IVSET(JFLD) == -1 ) THEN + IFLDS = IFLDS+1 + IF(PRESENT(KPTRGP)) THEN + IFLDA(IFLDS)=KPTRGP(JFLD) + ELSE + IFLDA(IFLDS)=JFLD + ENDIF ENDIF ENDDO - - - DO JJ=IRECV_FLD_START,IRECV_FLD_END - IFLDT=IFLDA(JJ) - DO JBLK=1,NGPBLKS - IFIRST = IGPTRSEND(1,JBLK,ISETW) - IF(IFIRST > 0) THEN - ILAST = IGPTRSEND(2,JBLK,ISETW) - IF(LLINDER) THEN - DO JK=IFIRST,ILAST - JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK)+JK-IFIRST+1 - PGP(JK,KPTRGP(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ENDDO - ELSEIF(LLPGPONLY) THEN - DO JK=IFIRST,ILAST - JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK)+JK-IFIRST+1 - PGP(JK,IFLDT,JBLK) = ZCOMBUFR(JI,INR) - ENDDO - ELSEIF(LLUV(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK)+JK-IFIRST+1 - PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ENDDO - ELSEIF(LLGP2(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK)+JK-IFIRST+1 - PGP2(JK,IGP2PARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ENDDO - ELSEIF(LLGP3A(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK)+JK-IFIRST+1 - PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ENDDO - ELSEIF(LLGP3B(IFLDT)) THEN - DO JK=IFIRST,ILAST - JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK)+JK-IFIRST+1 - PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) = ZCOMBUFR(JI,INR) - ENDDO + + !$ACC DATA COPYIN(IFLDA(1:IRECV_FIELD_COUNT_V)) ASYNC(1) + + IRECV_WSET_OFFSET_V = IRECV_WSET_OFFSET(ISETW) + IRECV_WSET_SIZE_V = IRECV_WSET_SIZE(ISETW) + IF (PRESENT(PGP)) THEN + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI) ASYNC(1) + DO JFLD=1,IRECV_FIELD_COUNT_V + DO JL=1,IRECV_WSET_SIZE_V + JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD=IFLDA(JFLD) + JI = ICOMBUFR_OFFSET_V+(JFLD-1)*IRECV_WSET_SIZE_V+JL + PGP(JK,IFLD,JBLK) = ZCOMBUFR(JI) + ENDDO + ENDDO + ELSE + !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI) ASYNC(1) + DO JFLD=1,IRECV_FIELD_COUNT_V + DO JL=1,IRECV_WSET_SIZE_V + JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 + JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 + IFLD=IFLDA(JFLD) + JI = ICOMBUFR_OFFSET_V+(JFLD-1)*IRECV_WSET_SIZE_V+JL + IF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_UV) THEN + PGPUV(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) + ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP2) THEN + PGP2(JK,IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) + ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3A) THEN + PGP3A(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) + ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3B) THEN + PGP3B(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) ENDIF - ENDIF + ENDDO ENDDO - ENDDO - - IPOS=(IRECV_FLD_END-IRECV_FLD_START+1)*IPOS + ENDIF + !$ACC END DATA ENDDO - !$OMP END PARALLEL DO - - #ifdef COMVERBOSE - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - Tc=(TIMEF()-Tc)/1000.0_JPRBT - !IF(MPL_MYRANK==1) WRITE(*,*) "unpacking (trltog) in sec: ", Tc - #endif - - CALL GSTATS(1606,1) - IF (IBUFLENS > 0) DEALLOCATE(ZCOMBUFS) - IF (IBUFLENR > 0) DEALLOCATE(ZCOMBUFR) - - IF (LHOOK) CALL DR_HOOK('TRLTOG',1,ZHOOK_HANDLE) - - END SUBROUTINE TRLTOG - END MODULE TRLTOG_MOD - + + !$ACC END DATA ! ZOMBUFR + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) + ENDIF + CALL GSTATS(422,0) + !$ACC END DATA ! PGP3B + !$ACC END DATA ! PGP3A + !$ACC END DATA ! PGP2 + !$ACC END DATA ! PGPUV + !$ACC END DATA ! PGP + IF (PRESENT(PGP)) THEN + !$ACC UPDATE HOST(PGP) ASYNC(1) + ENDIF + IF (PRESENT(PGPUV)) THEN + !$ACC UPDATE HOST(PGPUV) ASYNC(1) + ENDIF + IF (PRESENT(PGP2)) THEN + !$ACC UPDATE HOST(PGP2) ASYNC(1) + ENDIF + IF (PRESENT(PGP3A)) THEN + !$ACC UPDATE HOST(PGP3A) ASYNC(1) + ENDIF + IF (PRESENT(PGP3B)) THEN + !$ACC UPDATE HOST(PGP3B) ASYNC(1) + ENDIF + IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_DELETE(ACC_POINTERS(1:ACC_POINTERS_CNT),STREAM=1_ACC_HANDLE_KIND) + IF (LSYNC_TRANS) THEN + !$ACC WAIT(1) + CALL GSTATS(442,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(442,1) + ENDIF + CALL GSTATS(422,1) + !$ACC END DATA ! IRECVBUFR_TO_OUT,PGPINDICES + + !$ACC WAIT(1) + + CALL GSTATS(1606,1) + + IF (LHOOK) CALL DR_HOOK('TRLTOG',1,ZHOOK_HANDLE) + END SUBROUTINE TRLTOG_CUDAAWARE +END MODULE TRLTOG_MOD + diff --git a/src/trans/gpu/internal/trltom_mod.F90 b/src/trans/gpu/internal/trltom_mod.F90 index 6da1718a3..011952959 100755 --- a/src/trans/gpu/internal/trltom_mod.F90 +++ b/src/trans/gpu/internal/trltom_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 1995- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,323 +9,179 @@ ! MODULE TRLTOM_MOD - CONTAINS - SUBROUTINE TRLTOM_CUDAAWARE(PFBUF_IN,PFBUF,KFIELD) - - !**** *TRLTOM * - transposition in Fourierspace - - ! Purpose. - ! -------- - ! Transpose Fourier coefficients from partitioning - ! over latitudes to partitioning over wave numbers - ! This is done between inverse Legendre Transform - ! and inverse FFT. - ! This is the inverse routine of TRMTOL. - - !** Interface. - ! ---------- - ! *CALL* *TRLTOM(...)* - - ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is - ! -------------------- used for both input and output. - - ! KFIELD - Number of fields communicated - - ! Implicit arguments : - ! -------------------- - - ! Method. - ! ------- - ! See documentation - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! MPP Group *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 95-10-01 - ! Modified : 97-06-18 G. Mozdzynski - control MPI mailbox use - ! (NCOMBFLEN) for nphase.eq.1 - ! Modified : 99-05-28 D.Salmond - Optimise copies. - ! Modified : 00-02-02 M.Hamrud - Remove NPHASE - ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message - ! passing and buffer packing - ! G.Mozdzynski : 08-01-01 Cleanup - ! Y.Seity : 07-08-30 Add barrier synchonisation under LSYNC_TRANS - ! ------------------------------------------------------------------ - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK, MPL_WAIT, JP_NON_BLOCKING_STANDARD - - USE TPM_DISTR ,ONLY : D, MTAGLM, MYSETW, NPRTRW, NPROC, MYPROC - USE TPM_GEN ,ONLY : LSYNC_TRANS - - USE MPI - - !USE SET2PE_MOD - !USE MYSENDSET_MOD - !USE MYRECVSET_MOD - !USE ABORT_TRANS_MOD - ! - + USE ALLOCATOR_MOD IMPLICIT NONE - - - INTERFACE - - FUNCTION ALLTOALLV_CUDAIPC(input,len,soff,output,roff,mtol_or_ltom) BIND(C,name='Alltoallv_CUDAIPC') - USE, INTRINSIC :: ISO_C_BINDING - IMPLICIT NONE - real(c_double), dimension(*) :: input,output - integer(c_int), dimension(*) :: len,soff,roff - integer(c_int),value :: mtol_or_ltom - integer(c_int) :: ALLTOALLV_CUDAIPC - END FUNCTION ALLTOALLV_CUDAIPC - - END INTERFACE - - - INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD - REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF(:) - REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF_IN(:) - - INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) - - INTEGER(KIND=JPIM) :: ITAG, J, ILEN, ISTA - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR2 - - REAL(KIND=JPRBT) :: ZDUM(1) - INTEGER(KIND=JPIM) :: IREQ - INTEGER(KIND=JPIM) :: IERROR - ! ------------------------------------------------------------------ - - REAL(KIND=JPRBT) :: T1, T2, TIMEF, Tc - INTEGER(KIND=JPIM) :: MTOL_OR_LTOM, NOFULLPEERACCESS - INTEGER(KIND=JPIM) :: IRANK,IUNIT - INTEGER(KIND=JPIM) :: FROM_SEND,FROM_RECV,TO_RECV,TO_SEND - - - IF (LHOOK) CALL DR_HOOK('TRLTOM_CUDAAWARE',0,ZHOOK_HANDLE) - -#ifdef PARKINDTRANS_SINGLE -#define TRLTOM_DTYPE MPI_REAL -#else -#define TRLTOM_DTYPE MPI_DOUBLE_PRECISION -#endif - - ITAG = MTAGLM - - DO J=1,NPRTRW - ILENS(J) = D%NLTSGTB(J)*KFIELD - IOFFS(J) = D%NSTAGT1B(D%MSTABF(J))*KFIELD - ILENR(J) = D%NLTSFTB(J)*KFIELD - IOFFR(J) = D%NSTAGT1B(J)*KFIELD - ENDDO - - IF(NPROC > 1) THEN - CALL GSTATS(806,0) - IF (LSYNC_TRANS) THEN - CALL GSTATS(420,0) - CALL MPL_BARRIER(CDSTRING='TRLTOM BARRIER') - CALL GSTATS(420,1) - ENDIF - ! copy to self workaround - IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) - IF (ILENS(IRANK) .ne. ILENR(IRANK)) THEN - PRINT *, "ERROR", ILENS(IRANK), ILENR(IRANK) - stop 1 - ENDIF - IF (ILENS(IRANK) > 0) THEN - FROM_SEND = IOFFS(IRANK) + 1 - TO_SEND = FROM_SEND + ILENS(IRANK) - 1 - FROM_RECV = IOFFR(IRANK) + 1 - TO_RECV = FROM_RECV + ILENR(IRANK) - 1 - !$ACC KERNELS ASYNC(1) DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) - PFBUF(FROM_RECV:TO_RECV) = PFBUF_IN(FROM_SEND:TO_SEND) - !$ACC END KERNELS - ILENS(IRANK) = 0 - ILENR(IRANK) = 0 + PRIVATE + PUBLIC :: TRLTOM_CUDAAWARE, PREPARE_TRLTOM, TRLTOM_HANDLE + + TYPE TRLTOM_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPFBUF + END TYPE +CONTAINS + FUNCTION PREPARE_TRLTOM(ALLOCATOR, KF_FS) RESULT(HTRLTOM) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + TYPE(TRLTOM_HANDLE) :: HTRLTOM + + REAL(KIND=JPRBT) :: DUMMY + + HTRLTOM%HPFBUF = RESERVE(ALLOCATOR, D%NLENGT1B*2*KF_FS*SIZEOF(DUMMY)) + END FUNCTION + + SUBROUTINE TRLTOM_CUDAAWARE(ALLOCATOR,HTRLTOM,PFBUF_IN,PFBUF,KF_FS) + !**** *TRLTOM * - transposition in Fourierspace + + ! Purpose. + ! -------- + ! Transpose Fourier coefficients from partitioning + ! over latitudes to partitioning over wave numbers + ! This is done between inverse Legendre Transform + ! and inverse FFT. + ! This is the inverse routine of TRMTOL. + + !** Interface. + ! ---------- + ! *CALL* *TRLTOM(...)* + + ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is + ! -------------------- used for both input and output. + + ! KF_FS - Number of fields communicated + + ! Implicit arguments : + ! -------------------- + + ! Method. + ! ------- + ! See documentation + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! MPP Group *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 95-10-01 + ! Modified : 97-06-18 G. Mozdzynski - control MPI mailbox use + ! (NCOMBFLEN) for nphase.eq.1 + ! Modified : 99-05-28 D.Salmond - Optimise copies. + ! Modified : 00-02-02 M.Hamrud - Remove NPHASE + ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message + ! passing and buffer packing + ! G.Mozdzynski: 08-01-01 Cleanup + ! Y.Seity : 07-08-30 Add barrier synchronisation under LSYNC_TRANS + ! ------------------------------------------------------------------ + + USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK + USE TPM_DISTR ,ONLY : D, NPRTRW, NPROC, MYPROC, MYSETW + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE MPI + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + IMPLICIT NONE + + INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS + REAL(KIND=JPRBT) ,INTENT(OUT), POINTER :: PFBUF(:) + REAL(KIND=JPRBT) ,INTENT(INOUT), POINTER :: PFBUF_IN(:) + + INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) + INTEGER(KIND=JPIM) :: J, ILEN, ISTA, FROM_SEND, TO_SEND, FROM_RECV, TO_RECV, IRANK + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + INTEGER(KIND=JPIM) :: IERROR + + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRLTOM_HANDLE), INTENT(IN) :: HTRLTOM + + #ifdef PARKINDTRANS_SINGLE + #define TRLTOM_DTYPE MPI_REAL + #else + #define TRLTOM_DTYPE MPI_DOUBLE_PRECISION + #endif + + IF (LHOOK) CALL DR_HOOK('TRLTOM_CUDAAWARE',0,ZHOOK_HANDLE) + + CALL ASSIGN_PTR(PFBUF, GET_ALLOCATION(ALLOCATOR, HTRLTOM%HPFBUF),& + & 1_C_SIZE_T, D%NLENGT1B*2*KF_FS*SIZEOF(PFBUF(1))) + + !$ACC DATA PRESENT(PFBUF,PFBUF_IN) + + IF(NPROC > 1) THEN + DO J=1,NPRTRW + ILENS(J) = D%NLTSGTB(J)*2*KF_FS + IOFFS(J) = D%NSTAGT0B(J)*2*KF_FS + ILENR(J) = D%NLTSFTB(J)*2*KF_FS + IOFFR(J) = D%NSTAGT1B(J)*2*KF_FS + ENDDO + + CALL GSTATS(806,0) + + ! copy to self workaround + IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) + IF (ILENS(IRANK) .ne. ILENR(IRANK)) THEN + PRINT *, "ERROR", ILENS(IRANK), ILENR(IRANK) + stop 1 + ENDIF + IF (ILENS(IRANK) > 0) THEN + FROM_SEND = IOFFS(IRANK) + 1 + TO_SEND = FROM_SEND + ILENS(IRANK) - 1 + FROM_RECV = IOFFR(IRANK) + 1 + TO_RECV = FROM_RECV + ILENR(IRANK) - 1 + !$ACC KERNELS ASYNC(1) + PFBUF(FROM_RECV:TO_RECV) = PFBUF_IN(FROM_SEND:TO_SEND) + !$ACC END KERNELS + ILENS(IRANK) = 0 + ILENR(IRANK) = 0 + ENDIF + + IF (LSYNC_TRANS) THEN + CALL GSTATS(430,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(430,1) + ENDIF + CALL GSTATS(411,0) + !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) + CALL MPI_ALLTOALLV(PFBUF_IN,ILENS,IOFFS,TRLTOM_DTYPE,& + & PFBUF,ILENR,IOFFR, TRLTOM_DTYPE, & + & MPL_ALL_MS_COMM,IERROR) + !$ACC END HOST_DATA + IF (LSYNC_TRANS) THEN + CALL GSTATS(431,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(431,1) + ENDIF + CALL GSTATS(411,1) + + !$ACC WAIT(1) + CALL GSTATS(806,1) + ELSE + ILEN = D%NLTSGTB(MYSETW)*2*KF_FS + ISTA = D%NSTAGT1B(MYSETW)*2*KF_FS+1 + CALL GSTATS(1607,0) + !$ACC PARALLEL LOOP DEFAULT(NONE) + DO J=ISTA,ISTA+ILEN-1 + PFBUF(J) = PFBUF_IN(J) + ENDDO + CALL GSTATS(1607,1) ENDIF - - CALL GSTATS(411,0) - !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) - - CALL MPI_ALLTOALLV(PFBUF_IN,ILENS,IOFFS,TRLTOM_DTYPE,& - & PFBUF,ILENR,IOFFR, TRLTOM_DTYPE, & - & MPL_ALL_MS_COMM, IERROR) - - !$ACC END HOST_DATA - CALL GSTATS(411,1) - !$ACC WAIT(1) - - CALL MPI_BARRIER(MPI_COMM_WORLD,IERROR) - CALL GSTATS(806,1) - ELSE - ILEN = D%NLTSGTB(MYSETW)*KFIELD - ISTA = D%NSTAGT1B(MYSETW)*KFIELD+1 - CALL GSTATS(1607,0) - !$ACC PARALLEL LOOP DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) - DO J=ISTA,ISTA+ILEN-1 - PFBUF(J) = PFBUF_IN(J) - ENDDO - CALL GSTATS(1607,1) - ENDIF - - IF (LHOOK) CALL DR_HOOK('TRLTOM_CUDAAWARE',1,ZHOOK_HANDLE) - ! ------------------------------------------------------------------ - END SUBROUTINE TRLTOM_CUDAAWARE - SUBROUTINE TRLTOM(PFBUF_IN,PFBUF,KFIELD) - - !**** *TRLTOM * - transposition in Fourierspace - - ! Purpose. - ! -------- - ! Transpose Fourier coefficients from partitioning - ! over latitudes to partitioning over wave numbers - ! This is done between inverse Legendre Transform - ! and inverse FFT. - ! This is the inverse routine of TRMTOL. - - !** Interface. - ! ---------- - ! *CALL* *TRLTOM(...)* - - ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is - ! -------------------- used for both input and output. - - ! KFIELD - Number of fields communicated - - ! Implicit arguments : - ! -------------------- - - ! Method. - ! ------- - ! See documentation - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! MPP Group *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 95-10-01 - ! Modified : 97-06-18 G. Mozdzynski - control MPI mailbox use - ! (NCOMBFLEN) for nphase.eq.1 - ! Modified : 99-05-28 D.Salmond - Optimise copies. - ! Modified : 00-02-02 M.Hamrud - Remove NPHASE - ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message - ! passing and buffer packing - ! G.Mozdzynski : 08-01-01 Cleanup - ! Y.Seity : 07-08-30 Add barrier synchonisation under LSYNC_TRANS - ! ------------------------------------------------------------------ - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - - USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK, MPL_WAIT, JP_NON_BLOCKING_STANDARD - - USE TPM_DISTR ,ONLY : D, MTAGLM, MYSETW, NPRTRW, NPROC, MYPROC - USE TPM_GEN ,ONLY : LSYNC_TRANS - - USE MPI - - !USE SET2PE_MOD - !USE MYSENDSET_MOD - !USE MYRECVSET_MOD - !USE ABORT_TRANS_MOD - ! - - IMPLICIT NONE - - - INTERFACE - - FUNCTION ALLTOALLV_CUDAIPC(input,len,soff,output,roff,mtol_or_ltom) BIND(C,name='Alltoallv_CUDAIPC') - USE, INTRINSIC :: ISO_C_BINDING - IMPLICIT NONE - real(c_double), dimension(*) :: input,output - integer(c_int), dimension(*) :: len,soff,roff - integer(c_int),value :: mtol_or_ltom - integer(c_int) :: ALLTOALLV_CUDAIPC - END FUNCTION ALLTOALLV_CUDAIPC - - END INTERFACE - - - INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD - REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF(:) - REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF_IN(:) - - INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) - - INTEGER(KIND=JPIM) :: ITAG, J, ILEN, ISTA - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR2 - - REAL(KIND=JPRBT) :: ZDUM(1) - INTEGER(KIND=JPIM) :: IREQ - INTEGER(KIND=JPIM) :: IERROR - ! ------------------------------------------------------------------ - - REAL(KIND=JPRBT) :: T1, T2, TIMEF, tc - INTEGER(KIND=JPIM) :: MTOL_OR_LTOM, NOFULLPEERACCESS - INTEGER(KIND=JPIM) :: IRANK,iunit - - IF (LHOOK) CALL DR_HOOK('TRLTOM',0,ZHOOK_HANDLE) - - ITAG = MTAGLM - - DO J=1,NPRTRW - ILENS(J) = D%NLTSGTB(J)*KFIELD - IOFFS(J) = D%NSTAGT1B(D%MSTABF(J))*KFIELD - ILENR(J) = D%NLTSFTB(J)*KFIELD - IOFFR(J) = D%NSTAGT1B(J)*KFIELD - ENDDO - - IF(NPROC > 1) THEN - CALL GSTATS(806,0) - - CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN,KSENDCOUNTS=ILENS,& - & PRECVBUF=PFBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& - & KCOMM=MPL_ALL_MS_COMM,CDSTRING='TRLTOM:') - - call MPI_BARRIER(MPI_COMM_WORLD,IERROR) - CALL GSTATS(806,1) - ELSE - ILEN = D%NLTSGTB(MYSETW)*KFIELD - ISTA = D%NSTAGT1B(MYSETW)*KFIELD+1 - CALL GSTATS(1607,0) - DO J=ISTA,ISTA+ILEN-1 - PFBUF(J) = PFBUF_IN(J) - ENDDO - CALL GSTATS(1607,1) - ENDIF - - IF (LHOOK) CALL DR_HOOK('TRLTOM',1,ZHOOK_HANDLE) - ! ------------------------------------------------------------------ - END SUBROUTINE TRLTOM - END MODULE TRLTOM_MOD + !$ACC END DATA + + IF (LHOOK) CALL DR_HOOK('TRLTOM_CUDAAWARE',1,ZHOOK_HANDLE) + ! ------------------------------------------------------------------ + END SUBROUTINE TRLTOM_CUDAAWARE +END MODULE TRLTOM_MOD diff --git a/src/trans/gpu/internal/trltom_pack_unpack.F90 b/src/trans/gpu/internal/trltom_pack_unpack.F90 new file mode 100755 index 000000000..5c2a8fc01 --- /dev/null +++ b/src/trans/gpu/internal/trltom_pack_unpack.F90 @@ -0,0 +1,244 @@ +#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) +! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 TRLTOM_PACK_UNPACK + USE ALLOCATOR_MOD + IMPLICIT NONE + + PRIVATE + PUBLIC :: TRLTOM_PACK_HANDLE, PREPARE_TRLTOM_PACK, TRLTOM_PACK + PUBLIC :: TRLTOM_UNPACK_HANDLE, PREPARE_TRLTOM_UNPACK, TRLTOM_UNPACK + + TYPE TRLTOM_PACK_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN + END TYPE + TYPE TRLTOM_UNPACK_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HINPS_AND_ZINPA + END TYPE +CONTAINS + FUNCTION PREPARE_TRLTOM_PACK(ALLOCATOR, KF_FS) RESULT(HTRLTOM_PACK) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + TYPE(TRLTOM_PACK_HANDLE) :: HTRLTOM_PACK + + REAL(KIND=JPRBT) :: DUMMY + + HTRLTOM_PACK%HFOUBUF_IN = RESERVE(ALLOCATOR, D%NLENGT0B*KF_FS*2*SIZEOF(DUMMY)) + END FUNCTION + + SUBROUTINE TRLTOM_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) + !**** *TRLTOM_PACK* - Copy fourier data from local array to buffer + + ! Purpose. + ! -------- + ! Routine for copying fourier data from local array to buffer + + !** Interface. + ! ---------- + ! CALL TRLTOM_PACK(...) + + ! Explicit arguments : PREEL - local fourier/GP array + ! -------------------- KF_FS - number of fields + ! + ! Externals. None. + ! ---------- + + ! Author. + ! ------- + ! Mats Hamrud *ECMWF* + + ! ------------------------------------------------------------------ + + USE ALLOCATOR_MOD + USE PARKIND_ECTRANS, ONLY : JPIM,JPRBT + USE TPM_DISTR, ONLY : D,MYSETW,D_NSTAGTF,D_NPNTGTB0,D_NPTRLS + USE TPM_GEOMETRY, ONLY : G,G_NMEN,G_NLOEN + USE TPM_DIM, ONLY: R_NSMAX + USE ISO_C_BINDING + ! + + IMPLICIT NONE + + REAL(KIND=JPRBT), INTENT(IN) :: PREEL_COMPLEX(:) + REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: FOUBUF_IN(:) + INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRLTOM_PACK_HANDLE), INTENT(IN) :: HTRLTOM_PACK + + INTEGER(KIND=JPIM) :: JM,JF,IGLG,ISTA,OFFSET_VAR,IOFF_LAT,KGL + + REAL(KIND=JPRBT) :: SCAL + + CALL ASSIGN_PTR(FOUBUF_IN, GET_ALLOCATION(ALLOCATOR, HTRLTOM_PACK%HFOUBUF_IN),& + & 1_C_SIZE_T, D%NLENGT0B*KF_FS*2*SIZEOF(FOUBUF_IN(1))) + + !$ACC DATA PRESENT(D,G_NMEN,D_NPNTGTB0,FOUBUF_IN,PREEL_COMPLEX,D_NSTAGTF,G_NLOEN) ASYNC(1) + + ! scale results and move into next transformation buffer + + OFFSET_VAR=D_NPTRLS(MYSETW) + + !$ACC PARALLEL LOOP PRIVATE(IGLG,IOFF_LAT,ISTA,SCAL) DEFAULT(NONE) & + !$ACC& ASYNC(1) TILE(32,16,1) + DO KGL=1,D%NDGL_FS + DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) + DO JF=1,KF_FS + IGLG = OFFSET_VAR+KGL-1 + IF (JM <= G_NMEN(IGLG)) THEN + IOFF_LAT = KF_FS*D_NSTAGTF(KGL)+(JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + + SCAL = 1._JPRBT/REAL(G_NLOEN(IGLG),JPRBT) + ISTA = D_NPNTGTB0(JM,KGL)*KF_FS*2 + + FOUBUF_IN(ISTA+2*JF-1) = SCAL * PREEL_COMPLEX(IOFF_LAT+2*JM+1) + FOUBUF_IN(ISTA+2*JF ) = SCAL * PREEL_COMPLEX(IOFF_LAT+2*JM+2) + ENDIF + ENDDO + ENDDO + ENDDO + !$ACC END DATA + + !$ACC WAIT(1) + END SUBROUTINE TRLTOM_PACK + + FUNCTION PREPARE_TRLTOM_UNPACK(ALLOCATOR, KF_FS) RESULT(HTRLTOM_UNPACK) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD + USE TPM_DISTR, ONLY : D + USE LEDIR_MOD, ONLY: LEDIR_STRIDES + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS + TYPE(TRLTOM_UNPACK_HANDLE) :: HTRLTOM_UNPACK + + INTEGER(KIND=JPIM) :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE + INTEGER(KIND=C_SIZE_T) :: ISIZE + + REAL(KIND=JPRBT) :: ZPRBT_DUMMY + REAL(KIND=JPRD) :: ZPRD_DUMMY + + CALL LEDIR_STRIDES(KF_FS,IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& + IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) + + ! Check if the reuse buffer is large enough + ISIZE = ALIGN(IIN_SIZE*SIZEOF(ZPRBT_DUMMY),128) + ISIZE = ISIZE + ALIGN(IIN_SIZE*SIZEOF(ZPRBT_DUMMY),128) + ISIZE = ISIZE + ALIGN(IIN0_SIZE*SIZEOF(ZPRD_DUMMY),128) + ISIZE = ISIZE + ALIGN(IIN0_SIZE*SIZEOF(ZPRD_DUMMY),128) + + HTRLTOM_UNPACK%HINPS_AND_ZINPA = RESERVE(ALLOCATOR, ISIZE) + END FUNCTION + + SUBROUTINE TRLTOM_UNPACK(ALLOCATOR,HTRLTOM_UNPACK,FOUBUF,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV) + USE PARKIND_ECTRANS, ONLY : JPIM, JPRBT, JPRD + USE TPM_DIM, ONLY : R, R_NDGNH, R_NDGL + USE TPM_GEOMETRY, ONLY : G, G_NDGLU + USE TPM_FIELDS, ONLY : F + USE TPM_DISTR, ONLY : D,D_NUMP,D_MYMS, D_NPNTGTB1,D_OFFSETS_GEMM1 + USE LEDIR_MOD, ONLY : LEDIR_STRIDES + USE, INTRINSIC :: ISO_C_BINDING + + IMPLICIT NONE + + REAL(KIND=JPRBT), INTENT(IN) :: FOUBUF(:) + REAL(KIND=JPRBT), POINTER, INTENT(INOUT) :: ZINPS(:), ZINPA(:) + REAL(KIND=JPRD), POINTER, INTENT(INOUT) :: ZINPS0(:), ZINPA0(:) + INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRLTOM_UNPACK_HANDLE), INTENT(IN) :: HTRLTOM_UNPACK + + REAL(KIND=JPRBT), POINTER :: PREEL_COMPLEX(:) + + INTEGER(KIND=JPIM) :: IIN_STRIDES0, IIN_SIZE + INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE + + INTEGER(KIND=C_SIZE_T) :: IALLOC_POS, IALLOC_SZ + + INTEGER(KIND=8) :: JF + INTEGER(KIND=JPIM) :: KM, ISL, IGLS, OFFSET1, OFFSET2, JGL, KMLOC + + REAL(KIND=JPRBT) :: PAIA, PAIS + + CALL LEDIR_STRIDES(KF_FS,IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& + IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) + + IALLOC_POS=1 + + IALLOC_SZ = ALIGN(IIN_SIZE*SIZEOF(ZINPS(0)),128) + CALL ASSIGN_PTR(ZINPS, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS=IALLOC_POS+IALLOC_SZ + + IALLOC_SZ = ALIGN(IIN_SIZE*SIZEOF(ZINPA(0)),128) + CALL ASSIGN_PTR(ZINPA, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS=IALLOC_POS+IALLOC_SZ + + IALLOC_SZ = ALIGN(IIN0_SIZE*SIZEOF(ZINPS0(0)),128) + CALL ASSIGN_PTR(ZINPS0, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS=IALLOC_POS+IALLOC_SZ + + IALLOC_SZ = ALIGN(IIN0_SIZE*SIZEOF(ZINPA0(0)),128) + CALL ASSIGN_PTR(ZINPA0, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& + & IALLOC_POS, IALLOC_SZ) + IALLOC_POS=IALLOC_POS+IALLOC_SZ + + !$ACC DATA & + !$ACC& PRESENT(ZINPS,ZINPA,ZINPS0,ZINPA0) & + !$ACC& PRESENT(F,F%RW) & + !$ACC& PRESENT(D,D_MYMS,R,G,G_NDGLU) & + !$ACC& PRESENT(D_NPNTGTB1) + + !$ACC DATA PRESENT(FOUBUF,D_OFFSETS_GEMM1) + !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,JGL,PAIA,PAIS) ASYNC(1) + DO KMLOC=1,D_NUMP + DO JGL=1,R_NDGNH + DO JF=1,KF_FS*2 + KM = D_MYMS(KMLOC) + ISL = R_NDGNH-G_NDGLU(KM)+1 + IF (JGL >= ISL) THEN + !(DO JGL=ISL,R_NDGNH) + IGLS = R_NDGL+1-JGL + OFFSET1 = D_NPNTGTB1(KMLOC,JGL )*2*KF_FS + OFFSET2 = D_NPNTGTB1(KMLOC,IGLS)*2*KF_FS + PAIA = FOUBUF(OFFSET1+JF)-FOUBUF(OFFSET2+JF) + PAIS = FOUBUF(OFFSET1+JF)+FOUBUF(OFFSET2+JF) + IF (JF <= 4*KF_UV) THEN + ! Multiply in case of velocity + PAIA = PAIA*F%RACTHE(JGL) + PAIS = PAIS*F%RACTHE(JGL) + ENDIF + IF (KM /= 0) THEN + ZINPA(JF+(JGL-ISL)*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC))=PAIA*F%RW(JGL) + ZINPS(JF+(JGL-ISL)*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC))=PAIS*F%RW(JGL) + ELSEIF (MOD(JF-1,2) == 0) THEN + ! every other field is sufficient because Im(KM=0) == 0 + ZINPA0((JF-1)/2+1+(JGL-1)*IIN0_STRIDES0)=PAIA*F%RW(JGL) + ZINPS0((JF-1)/2+1+(JGL-1)*IIN0_STRIDES0)=PAIS*F%RW(JGL) + ENDIF + ENDIF + ENDDO + ENDDO + END DO + !$ACC END DATA + + !$ACC END DATA + END SUBROUTINE +END MODULE TRLTOM_PACK_UNPACK + diff --git a/src/trans/gpu/internal/trmtol_mod.F90 b/src/trans/gpu/internal/trmtol_mod.F90 index 24248cc8e..b640e201c 100755 --- a/src/trans/gpu/internal/trmtol_mod.F90 +++ b/src/trans/gpu/internal/trmtol_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 1995- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -8,303 +9,176 @@ ! MODULE TRMTOL_MOD + USE ALLOCATOR_MOD + IMPLICIT NONE -CONTAINS -SUBROUTINE TRMTOL_CUDAAWARE(PFBUF_IN,PFBUF,KFIELD) - -!**** *trmtol * - transposition in Fourier space - -! Purpose. -! -------- -! Transpose Fourier buffer data from partitioning -! over wave numbers to partitioning over latitudes. -! It is called between direct FFT and direct Legendre -! transform. -! This routine is the inverse of TRLTOM. - - -!** Interface. -! ---------- -! *call* *trmtol(...)* - -! Explicit arguments : PFBUF - Fourier coefficient buffer. It is -! -------------------- used for both input and output. -! KFIELD - Number of fields communicated - -! Implicit arguments : -! -------------------- - -! Method. -! ------- -! See documentation - -! Externals. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! MPP Group *ECMWF* - -! Modifications. -! -------------- -! Original : 95-10-01 -! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use -! (NCOMBFLEN) for nphase.eq.1 -! Modified : 99-05-28 D.Salmond - Optimise copies. -! Modified : 00-02-02 M.Hamrud - Remove NPHASE -! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message -! passing and buffer packing -! G.Mozdzynski: 08-01-01 Cleanup -! Y.Seity : 07-08-31 add barrien synchronisation under LSYNC_TRANS -! ------------------------------------------------------------------ - - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_MYRANK - -USE TPM_DISTR ,ONLY : D, MTAGML, MYSETW, NPRTRW, NPROC, MYPROC -USE TPM_GEN ,ONLY : LSYNC_TRANS - -USE MPI - -IMPLICIT NONE - - -INTEGER(KIND=JPIM) ,INTENT(IN) :: KFIELD -REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF(:) -REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF_IN(:) - -INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) - -INTEGER(KIND=JPIM) :: ITAG, J, ILEN, ISTA - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR2 - -REAL(KIND=JPRBT) :: ZDUM(1) -INTEGER(KIND=JPIM) :: IREQ, IERROR, IRANK -INTEGER(KIND=JPIM) :: FROM_SEND,FROM_RECV,TO_RECV,TO_SEND - -#ifdef PARKINDTRANS_SINGLE -#define TRMTOL_DTYPE MPI_REAL -#else -#define TRMTOL_DTYPE MPI_DOUBLE_PRECISION -#endif - -! ------------------------------------------------------------------ - -IF (LHOOK) CALL DR_HOOK('TRMTOL_CUDAAWARE',0,ZHOOK_HANDLE) - -ITAG = MTAGML - -DO J=1,NPRTRW - ILENS(J) = D%NLTSFTB(J)*KFIELD - IOFFS(J) = D%NSTAGT0B(J)*KFIELD - ILENR(J) = D%NLTSGTB(J)*KFIELD - IOFFR(J) = D%NSTAGT0B(D%MSTABF(J))*KFIELD -ENDDO - -!write(300+myproc,*)"0:TRMTOL:PFBUF",sum(PFBUF) -!write(300+myproc,*)"0:TRMTOL:PFBUF_IN",sum(PFBUF_IN) -!call flush(300) -IF(NPROC > 1) THEN - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR',0,ZHOOK_HANDLE_BAR) - ! CALL GSTATS_BARRIER(764) - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR',1,ZHOOK_HANDLE_BAR) - IF (LSYNC_TRANS) THEN - CALL GSTATS(421,0) - CALL MPL_BARRIER(CDSTRING='TRLTOM BARRIER') - CALL GSTATS(421,1) - ENDIF - - ! copy to self workaround - IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) - IF (ILENS(IRANK) > 0) THEN - FROM_SEND = IOFFS(IRANK) + 1 - TO_SEND = FROM_SEND + ILENS(IRANK) - 1 - FROM_RECV = IOFFR(IRANK) + 1 - TO_RECV = FROM_RECV + ILENR(IRANK) - 1 - !$ACC KERNELS ASYNC(1) DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) - PFBUF(FROM_RECV:TO_RECV) = PFBUF_IN(FROM_SEND:TO_SEND) - !$ACC END KERNELS - ILENS(IRANK) = 0 - ILENR(IRANK) = 0 - ENDIF - CALL GSTATS(410,0) - - !$ACC DATA PRESENT(PFBUF_IN, PFBUF) - !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) - CALL GSTATS(807,0) - CALL MPI_ALLTOALLV(PFBUF_IN,ILENS,IOFFS,TRMTOL_DTYPE,& - & PFBUF,ILENR,IOFFR,TRMTOL_DTYPE,& - & MPL_ALL_MS_COMM,IERROR) - - !$ACC END HOST_DATA - !$ACC END DATA - CALL GSTATS(410,1) - CALL GSTATS(807,1) - !$ACC WAIT(1) - - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR2',0,ZHOOK_HANDLE_BAR2) - !CALL GSTATS_BARRIER2(764) - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR2',1,ZHOOK_HANDLE_BAR2) -ELSE - ILEN = D%NLTSGTB(MYSETW)*KFIELD - ISTA = D%NSTAGT0B(MYSETW)*KFIELD+1 - CALL GSTATS(1608,0) - !$ACC PARALLEL LOOP DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) - DO J=ISTA,ISTA+ILEN-1 - PFBUF(J) = PFBUF_IN(J) - ENDDO - CALL GSTATS(1608,1) -ENDIF -!write(300+myproc,*)"10:TRMTOL:PFBUF",sum(PFBUF), KFIELD, D%NLTSGTB(MYSETW), MYSETW, D%NSTAGT0B(MYSETW), D%NLTSFTB(MYSETW), D%MSTABF(MYSETW) -!write(300+myproc,*)"10:TRMTOL:PFBUF_IN",sum(PFBUF_IN) -!call flush(300+myproc) - -IF (LHOOK) CALL DR_HOOK('TRMTOL_CUDAAWARE',1,ZHOOK_HANDLE) - -! ------------------------------------------------------------------ - -END SUBROUTINE TRMTOL_CUDAAWARE - -SUBROUTINE TRMTOL(PFBUF_IN,PFBUF,KFIELD) - -!**** *trmtol * - transposition in Fourier space - -! Purpose. -! -------- -! Transpose Fourier buffer data from partitioning -! over wave numbers to partitioning over latitudes. -! It is called between direct FFT and direct Legendre -! transform. -! This routine is the inverse of TRLTOM. - - -!** Interface. -! ---------- -! *call* *trmtol(...)* - -! Explicit arguments : PFBUF - Fourier coefficient buffer. It is -! -------------------- used for both input and output. -! KFIELD - Number of fields communicated - -! Implicit arguments : -! -------------------- - -! Method. -! ------- -! See documentation - -! Externals. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! MPP Group *ECMWF* - -! Modifications. -! -------------- -! Original : 95-10-01 -! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use -! (NCOMBFLEN) for nphase.eq.1 -! Modified : 99-05-28 D.Salmond - Optimise copies. -! Modified : 00-02-02 M.Hamrud - Remove NPHASE -! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message -! passing and buffer packing -! G.Mozdzynski: 08-01-01 Cleanup -! Y.Seity : 07-08-31 add barrien synchronisation under LSYNC_TRANS -! ------------------------------------------------------------------ - - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_MYRANK - -USE TPM_DISTR ,ONLY : D, MTAGML, MYSETW, NPRTRW, NPROC, MYPROC -USE TPM_GEN ,ONLY : LSYNC_TRANS - - -IMPLICIT NONE - - -INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD -REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF(:) -REAL(KIND=JPRBT) ,INTENT(INOUT) :: PFBUF_IN(:) - -INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) - -INTEGER(KIND=JPIM) :: ITAG, J, ILEN, ISTA - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR2 - -REAL(KIND=JPRBT) :: ZDUM(1) -INTEGER(KIND=JPIM) :: IREQ - - -! ------------------------------------------------------------------ - -IF (LHOOK) CALL DR_HOOK('TRMTOL',0,ZHOOK_HANDLE) + PRIVATE + PUBLIC :: TRMTOL_CUDAAWARE, PREPARE_TRMTOL, TRMTOL_HANDLE - -ITAG = MTAGML - -DO J=1,NPRTRW - ILENS(J) = D%NLTSFTB(J)*KFIELD - IOFFS(J) = D%NSTAGT0B(J)*KFIELD - ILENR(J) = D%NLTSGTB(J)*KFIELD - IOFFR(J) = D%NSTAGT0B(D%MSTABF(J))*KFIELD -ENDDO - -!write(300+myproc,*)"0:TRMTOL:PFBUF",sum(PFBUF) -!write(300+myproc,*)"0:TRMTOL:PFBUF_IN",sum(PFBUF_IN) -!call flush(300) -IF(NPROC > 1) THEN - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR',0,ZHOOK_HANDLE_BAR) - ! CALL GSTATS_BARRIER(764) - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR',1,ZHOOK_HANDLE_BAR) -! IF (LSYNC_TRANS) THEN -! CALL MPL_BARRIER(CDSTRING='TRMTOL') -! ENDIF - - CALL GSTATS(807,0) - CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN,KSENDCOUNTS=ILENS,& - & PRECVBUF=PFBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& - & KCOMM=MPL_ALL_MS_COMM,CDSTRING='TRMTOL:') - CALL GSTATS(807,1) - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR2',0,ZHOOK_HANDLE_BAR2) - !CALL GSTATS_BARRIER2(764) - IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR2',1,ZHOOK_HANDLE_BAR2) -ELSE - ILEN = D%NLTSGTB(MYSETW)*KFIELD - ISTA = D%NSTAGT0B(MYSETW)*KFIELD+1 - CALL GSTATS(1608,0) - DO J=ISTA,ISTA+ILEN-1 - PFBUF(J) = PFBUF_IN(J) - ENDDO - CALL GSTATS(1608,1) -ENDIF -!write(300+myproc,*)"10:TRMTOL:PFBUF",sum(PFBUF), KFIELD, D%NLTSGTB(MYSETW), MYSETW, D%NSTAGT0B(MYSETW), D%NLTSFTB(MYSETW), D%MSTABF(MYSETW) -!write(300+myproc,*)"10:TRMTOL:PFBUF_IN",sum(PFBUF_IN) -!call flush(300+myproc) - -IF (LHOOK) CALL DR_HOOK('TRMTOL',1,ZHOOK_HANDLE) - -! ------------------------------------------------------------------ - -END SUBROUTINE TRMTOL + TYPE TRMTOL_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPFBUF + END TYPE +CONTAINS + FUNCTION PREPARE_TRMTOL(ALLOCATOR, KF_LEG) RESULT(HTRMTOL) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG + TYPE(TRMTOL_HANDLE) :: HTRMTOL + + REAL(KIND=JPRBT) :: DUMMY + + HTRMTOL%HPFBUF = RESERVE(ALLOCATOR, D%NLENGT0B*2*KF_LEG*SIZEOF(DUMMY)) + END FUNCTION + + SUBROUTINE TRMTOL_CUDAAWARE(ALLOCATOR,HTRMTOL,PFBUF_IN,PFBUF,KF_LEG) + !**** *trmtol * - transposition in Fourier space + + ! Purpose. + ! -------- + ! Transpose Fourier buffer data from partitioning + ! over wave numbers to partitioning over latitudes. + ! It is called between direct FFT and direct Legendre + ! transform. + ! This routine is the inverse of TRLTOM. + + + !** Interface. + ! ---------- + ! *call* *trmtol(...)* + + ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is + ! -------------------- used for both input and output. + ! KF_LEG - Number of fields communicated + + ! Implicit arguments : + ! -------------------- + + ! Method. + ! ------- + ! See documentation + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! MPP Group *ECMWF* + + ! Modifications. + ! -------------- + ! Original : 95-10-01 + ! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use + ! (NCOMBFLEN) for nphase.eq.1 + ! Modified : 99-05-28 D.Salmond - Optimise copies. + ! Modified : 00-02-02 M.Hamrud - Remove NPHASE + ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message + ! passing and buffer packing + ! G.Mozdzynski: 08-01-01 Cleanup + ! Y.Seity : 07-08-31 add barrier synchronisation under LSYNC_TRANS + ! ------------------------------------------------------------------ + + USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK + USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK + USE TPM_DISTR ,ONLY : D, NPRTRW, NPROC, MYPROC, MYSETW + USE TPM_GEN ,ONLY : LSYNC_TRANS + USE MPI + USE TPM_STATS, ONLY : GSTATS => GSTATS_NVTX + + IMPLICIT NONE + + INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_LEG + REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PFBUF(:) + REAL(KIND=JPRBT), INTENT(IN) :: PFBUF_IN(:) + + INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) + INTEGER(KIND=JPIM) :: J, ILEN, ISTA, FROM_SEND, TO_SEND, FROM_RECV, TO_RECV, IRANK + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + INTEGER(KIND=JPIM) :: IERROR + + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRMTOL_HANDLE), INTENT(IN) :: HTRMTOL + + #ifdef PARKINDTRANS_SINGLE + #define TRMTOL_DTYPE MPI_REAL + #else + #define TRMTOL_DTYPE MPI_DOUBLE_PRECISION + #endif + + IF (LHOOK) CALL DR_HOOK('TRMTOL_CUDAAWARE',0,ZHOOK_HANDLE) + + CALL ASSIGN_PTR(PFBUF, GET_ALLOCATION(ALLOCATOR, HTRMTOL%HPFBUF),& + & 1_C_SIZE_T, D%NLENGT0B*2*KF_LEG*SIZEOF(PFBUF(1))) + + IF(NPROC > 1) THEN + DO J=1,NPRTRW + ILENS(J) = D%NLTSFTB(J)*2*KF_LEG + IOFFS(J) = D%NSTAGT1B(J)*2*KF_LEG + ILENR(J) = D%NLTSGTB(J)*2*KF_LEG + IOFFR(J) = D%NSTAGT0B(J)*2*KF_LEG + ENDDO + + CALL GSTATS(807,0) + + ! copy to self workaround + IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) + IF (ILENS(IRANK) .ne. ILENR(IRANK)) THEN + PRINT *, "ERROR", ILENS(IRANK), ILENR(IRANK) + stop 1 + ENDIF + IF (ILENS(IRANK) > 0) THEN + FROM_SEND = IOFFS(IRANK) + 1 + TO_SEND = FROM_SEND + ILENS(IRANK) - 1 + FROM_RECV = IOFFR(IRANK) + 1 + TO_RECV = FROM_RECV + ILENR(IRANK) - 1 + !$ACC KERNELS ASYNC(1) DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) + PFBUF(FROM_RECV:TO_RECV) = PFBUF_IN(FROM_SEND:TO_SEND) + !$ACC END KERNELS + ILENS(IRANK) = 0 + ILENR(IRANK) = 0 + ENDIF + + IF (LSYNC_TRANS) THEN + CALL GSTATS(440,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(440,1) + ENDIF + CALL GSTATS(421,0) + !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) + CALL MPI_ALLTOALLV(PFBUF_IN,ILENS,IOFFS,TRMTOL_DTYPE,& + & PFBUF,ILENR,IOFFR,TRMTOL_DTYPE,& + & MPL_ALL_MS_COMM,IERROR) + !$ACC END HOST_DATA + IF (LSYNC_TRANS) THEN + CALL GSTATS(441,0) + CALL MPL_BARRIER(CDSTRING='') + CALL GSTATS(441,1) + ENDIF + CALL GSTATS(421,1) + + !$ACC WAIT(1) + CALL GSTATS(807,1) + ELSE + ILEN = D%NLTSGTB(MYSETW)*2*KF_LEG + ISTA = D%NSTAGT0B(MYSETW)*2*KF_LEG+1 + CALL GSTATS(1608,0) + !$ACC PARALLEL LOOP DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) + DO J=ISTA,ISTA+ILEN-1 + PFBUF(J) = PFBUF_IN(J) + ENDDO + CALL GSTATS(1608,1) + ENDIF + + IF (LHOOK) CALL DR_HOOK('TRMTOL_CUDAAWARE',1,ZHOOK_HANDLE) + + ! ------------------------------------------------------------------ + END SUBROUTINE TRMTOL_CUDAAWARE END MODULE TRMTOL_MOD diff --git a/src/trans/gpu/internal/trmtol_pack_unpack.F90 b/src/trans/gpu/internal/trmtol_pack_unpack.F90 new file mode 100755 index 000000000..9b3595a51 --- /dev/null +++ b/src/trans/gpu/internal/trmtol_pack_unpack.F90 @@ -0,0 +1,264 @@ +! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not 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 TRMTOL_PACK_UNPACK + USE ALLOCATOR_MOD + IMPLICIT NONE + + PRIVATE + PUBLIC :: TRMTOL_PACK, TRMTOL_PACK_HANDLE, PREPARE_TRMTOL_PACK + PUBLIC :: TRMTOL_UNPACK, TRMTOL_UNPACK_HANDLE, PREPARE_TRMTOL_UNPACK + + TYPE TRMTOL_PACK_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN + END TYPE + TYPE TRMTOL_UNPACK_HANDLE + TYPE(ALLOCATION_RESERVATION_HANDLE) :: HREEL + END TYPE + +CONTAINS + FUNCTION PREPARE_TRMTOL_PACK(ALLOCATOR,KF_LEG) RESULT(HTRMTOL_PACK) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD + USE TPM_DISTR, ONLY: D + USE TPM_DIM, ONLY: R + USE ISO_C_BINDING + USE LEINV_MOD + USE ALLOCATOR_MOD + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG + + TYPE(TRMTOL_PACK_HANDLE) :: HTRMTOL_PACK + + INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ + + REAL(KIND=JPRBT) :: ZPRBT_DUMMY + + IALLOC_SZ = D%NLENGT1B*2*KF_LEG*SIZEOF(ZPRBT_DUMMY) + HTRMTOL_PACK%HFOUBUF_IN = RESERVE(ALLOCATOR, IALLOC_SZ) + END FUNCTION + SUBROUTINE TRMTOL_PACK(ALLOCATOR,HTRMTOL_PACK,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,KF_LEG) + + !**** *TRMTOL_PACK* - Packing buffer for TRMTOL + + ! Purpose. + ! -------- + ! Packs data from LTINV outputs into FOUBUF for conversion to fourier space + + !** Interface. + ! ---------- + ! CALL TRMTOL_PACK(...) + + ! Explicit arguments : ZOUTS - symmetric data + ! -------------------- ZOUTA - asymmetric data + ! ZOUTS0 - symmetric data for KMLOC0 + ! ZOUTA0 - asymmetric data for KMLOC0 + ! FOUBUF_IN - output towards TRMTOL + ! KF_LEG - number of fields (we have 2XKF_LEG because complex) + + ! Implicit arguments : None. + ! -------------------- + + ! Externals. + ! ---------- + + ! Reference. + ! ---------- + ! ECMWF Research Department documentation of the IFS + + ! Author. + ! ------- + ! Nils Wedi + Mats Hamrud + George Modzynski + ! + ! Modifications. + ! -------------- + ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: + ! F. Vana 05-Mar-2015 Support for single precision + ! ------------------------------------------------------------------ + + USE PARKIND_ECTRANS ,ONLY : JPIM,JPRB,JPRBT,JPRD + USE YOMHOOK, ONLY : LHOOK,DR_HOOK, JPHOOK + USE TPM_DIM, ONLY : R, R_NDGNH,R_NDGL + USE TPM_GEOMETRY,ONLY : G,G_NDGLU + USE TPM_DISTR, ONLY : D,D_NUMP,D_MYMS,D_NPNTGTB1,D_OFFSETS_GEMM1 + USE LEINV_MOD, ONLY: LEINV_STRIDES + + IMPLICIT NONE + + + ! DUMMY ARGUMENTS + TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR + TYPE(TRMTOL_PACK_HANDLE), INTENT(IN) :: HTRMTOL_PACK + REAL(KIND=JPRB), INTENT(OUT), POINTER :: FOUBUF_IN(:) + REAL(KIND=JPRBT), INTENT(IN) :: ZOUTS(:), ZOUTA(:) + REAL(KIND=JPRD), INTENT(IN) :: ZOUTS0(:), ZOUTA0(:) + INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG + + ! LOCAL + REAL(KIND=JPRBT) :: ZAOA, ZSOA + + INTEGER(KIND=JPIM) :: KMLOC, KM, ISL, JGL, JK, IGLS, OFFSET1, OFFSET2 + INTEGER(KIND=JPIM) :: IOUT_STRIDES0, IOUT_SIZE + INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + IF (LHOOK) CALL DR_HOOK('TRMTOL_PACK',0,ZHOOK_HANDLE) + + CALL ASSIGN_PTR(FOUBUF_IN, GET_ALLOCATION(ALLOCATOR, HTRMTOL_PACK%HFOUBUF_IN),& + & 1_C_SIZE_T, D%NLENGT1B*2*KF_LEG*SIZEOF(FOUBUF_IN(1))) + + CALL LEINV_STRIDES(KF_LEG,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& + IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) + + !$ACC DATA PRESENT(D,D_MYMS,D_NPNTGTB1,G,G_NDGLU) & + !$ACC& PRESENT(ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,D_OFFSETS_GEMM1) + + !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,ZAOA,ZSOA) ASYNC(1) + DO KMLOC=1,D_NUMP + DO JGL=1,R_NDGNH + DO JK=1,2*KF_LEG + KM = D_MYMS(KMLOC) + ISL = R_NDGNH-G_NDGLU(KM)+1 + IF (JGL >= ISL) THEN + !(DO JGL=ISL,R_NDGNH) + IGLS = R_NDGL+1-JGL + OFFSET1 = D_NPNTGTB1(KMLOC,JGL )*2*KF_LEG + OFFSET2 = D_NPNTGTB1(KMLOC,IGLS)*2*KF_LEG + + IF(KM /= 0) THEN + ZSOA = ZOUTS(JK+(JGL-ISL)*IOUT_STRIDES0+D_OFFSETS_GEMM1(KMLOC)*IOUT_STRIDES0) + ZAOA = ZOUTA(JK+(JGL-ISL)*IOUT_STRIDES0+D_OFFSETS_GEMM1(KMLOC)*IOUT_STRIDES0) + ELSEIF (MOD((JK-1),2) .EQ. 0) THEN + ZSOA = ZOUTS0((JK-1)/2+1+(JGL-1)*IOUT0_STRIDES0) + ZAOA = ZOUTA0((JK-1)/2+1+(JGL-1)*IOUT0_STRIDES0) + ELSE + ! Imaginary values of KM=0 is zero, though I don't think we care + ZSOA = 0_JPRBT + ZAOA = 0_JPRBT + ENDIF + + FOUBUF_IN(OFFSET1+JK) = ZAOA+ZSOA + FOUBUF_IN(OFFSET2+JK) = ZSOA-ZAOA + ENDIF + ENDDO + ENDDO + ENDDO + + !$ACC WAIT(1) + + !$ACC END DATA + + IF (LHOOK) CALL DR_HOOK('TRMTOL_PACK',1,ZHOOK_HANDLE) + + END SUBROUTINE TRMTOL_PACK + + FUNCTION PREPARE_TRMTOL_UNPACK(ALLOCATOR,KF_FS) RESULT(HTRMTOL_UNPACK) + USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT + USE TPM_DISTR, ONLY: D + + IMPLICIT NONE + + TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR + INTEGER(KIND=JPIM) :: KF_FS + + TYPE(TRMTOL_UNPACK_HANDLE) :: HTRMTOL_UNPACK + + REAL(KIND=JPRBT) :: DUMMY + + HTRMTOL_UNPACK%HREEL = RESERVE(ALLOCATOR, D%NLENGTF*KF_FS*SIZEOF(DUMMY)) + + END FUNCTION +SUBROUTINE TRMTOL_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL_COMPLEX,KF_CURRENT,KF_TOTAL) + +!**** *TRMTOL_UNPACK* - Copy fourier data from buffer to local array + +! Purpose. +! -------- +! Routine for copying fourier data from buffer to local array + +!** Interface. +! ---------- +! CALL TRMTOL_UNPACK(...) + +! Explicit arguments : PREEL_COMPLEX - local fourier/GP array +! -------------------- KF_CURRENT - number of fields that are read (from Legendre space) +! KF_TOTAL - total fields in PREEL ("stride") +! +! Externals. None. +! ---------- + +! Author. +! ------- +! Mats Hamrud *ECMWF* + +! Modifications. +! -------------- +! Original : 2000-04-01 + +! ------------------------------------------------------------------ + +USE PARKIND_ECTRANS ,ONLY : JPIM,JPRBT +USE TPM_DISTR ,ONLY : D,MYSETW,MYPROC, NPROC, D_NSTAGTF, D_NPNTGTB0,D_NPTRLS +USE TPM_GEOMETRY ,ONLY : G,G_NMEN,G_NLOEN,G_NLOEN_MAX +! + +IMPLICIT NONE + +REAL(KIND=JPRBT), INTENT(IN) :: FOUBUF(:) +REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) +INTEGER(KIND=JPIM),INTENT(IN) :: KF_CURRENT, KF_TOTAL +TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR +TYPE(TRMTOL_UNPACK_HANDLE), INTENT(IN) :: HTRMTOL_UNPACK + +INTEGER(KIND=JPIM) :: JM,JF,IGLG,ISTA,OFFSET_VAR,IOFF_LAT,KGL +REAL(KIND=JPRBT) :: RET_REAL, RET_COMPLEX + +CALL ASSIGN_PTR(PREEL_COMPLEX, GET_ALLOCATION(ALLOCATOR, HTRMTOL_UNPACK%HREEL),& + & 1_C_SIZE_T, KF_TOTAL*D%NLENGTF*SIZEOF(PREEL_COMPLEX(1))) + +!$ACC DATA PRESENT(D,G_NLOEN,G_NMEN,D_NPNTGTB0,FOUBUF,PREEL_COMPLEX,D_NSTAGTF) ASYNC(1) + +OFFSET_VAR=D_NPTRLS(MYSETW) +!$ACC PARALLEL LOOP PRIVATE(IGLG,IOFF_LAT,ISTA,RET_REAL,RET_COMPLEX) DEFAULT(NONE) & +!$ACC& ASYNC(1) TILE(32,16,1) +DO KGL=1,D%NDGL_FS + DO JF=1,KF_CURRENT + DO JM=0,G_NLOEN_MAX/2 + IGLG = OFFSET_VAR+KGL-1 + + ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have + ! to fill those floor(NLON/2)+1 values. + ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. + IF (JM <= G_NLOEN(IGLG)/2) THEN + RET_REAL = 0.0_JPRBT + RET_COMPLEX = 0.0_JPRBT + IF (JM <= G_NMEN(IGLG)) THEN + ISTA = D_NPNTGTB0(JM,KGL)*KF_CURRENT*2 + + RET_REAL = FOUBUF(ISTA+2*JF-1) + RET_COMPLEX = FOUBUF(ISTA+2*JF ) + ENDIF + IOFF_LAT = KF_TOTAL*D_NSTAGTF(KGL)+(JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) + PREEL_COMPLEX(IOFF_LAT+2*JM+1) = RET_REAL + PREEL_COMPLEX(IOFF_LAT+2*JM+2) = RET_COMPLEX + ENDIF + ENDDO + ENDDO +ENDDO +!$ACC END DATA + +!$ACC WAIT(1) + +END SUBROUTINE TRMTOL_UNPACK +END MODULE TRMTOL_PACK_UNPACK + diff --git a/src/trans/gpu/internal/updsp_mod.F90 b/src/trans/gpu/internal/updsp_mod.F90 index aa5f4c5f8..df4f18227 100755 --- a/src/trans/gpu/internal/updsp_mod.F90 +++ b/src/trans/gpu/internal/updsp_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 1988- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -9,8 +10,8 @@ MODULE UPDSP_MOD CONTAINS -SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1,POA2, & - & PSPVOR,PSPDIV,PSPSCALAR,& +SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1, & + & PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) @@ -29,9 +30,6 @@ SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1,POA2, & ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) -! POA2 - spectral fields for zonal wavenumber KM (vor. div.) -! PSPVOR - spectral vorticity -! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : @@ -77,9 +75,6 @@ SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1,POA2, & INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS REAL(KIND=JPRBT) , INTENT(IN) :: POA1(:,:,:) -REAL(KIND=JPRBT) , INTENT(IN) :: POA2(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) @@ -88,7 +83,7 @@ SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1,POA2, & INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND,JFLD,IFLD,IDIM1,IDIM3,J3 +INTEGER(KIND=JPIM) :: IST ,IEND,JFLD,IFLD,IDIM1,IDIM3,J3 ! ------------------------------------------------------------------ @@ -98,24 +93,13 @@ SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1,POA2, & !* 1.1 VORTICITY AND DIVERGENCE. -!$ACC DATA PRESENT(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA PRESENT(PSPSCALAR) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSCALAR)) -!$ACC DATA PRESENT(PSPSC2) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSC2) .AND. NF_SC2 > 0) -!$ACC DATA PRESENT(PSPSC3A) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSC3A) .AND. NF_SC3A > 0) -!$ACC DATA PRESENT(PSPSC3B) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSC3B) .AND. NF_SC3B > 0) +!$ACC DATA PRESENT(PSPSC2) IF(NF_SC2 > 0) +!$ACC DATA PRESENT(PSPSC3A) IF(NF_SC3A > 0) +!$ACC DATA PRESENT(PSPSC3B) IF(NF_SC3B > 0) IST = 1 -IF (KF_UV > 0) THEN - !stop 'Error: code path not (yet) supported in GPU version' - - IST = IST+4*KF_UV - IVORS = 1 - IVORE = 2*KF_UV - IDIVS = 2*KF_UV+1 - IDIVE = 4*KF_UV - CALL UPDSPB(KF_UV,POA2(IVORS:IVORE,:,:),PSPVOR,KFLDPTRUV) - CALL UPDSPB(KF_UV,POA2(IDIVS:IDIVE,:,:),PSPDIV,KFLDPTRUV) -ENDIF +IST = IST+4*KF_UV !* 1.2 SCALARS @@ -155,7 +139,6 @@ SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1,POA2, & !$ACC END DATA !$ACC END DATA !$ACC END DATA -!$ACC END DATA ! ------------------------------------------------------------------ diff --git a/src/trans/gpu/internal/updspad_mod.F90 b/src/trans/gpu/internal/updspad_mod.F90 deleted file mode 100755 index 16e9111c6..000000000 --- a/src/trans/gpu/internal/updspad_mod.F90 +++ /dev/null @@ -1,177 +0,0 @@ -! (C) Copyright 1988- 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 UPDSPAD_MOD -CONTAINS -SUBROUTINE UPDSPAD(KM,KF_UV,KF_SCALARS,POA1,POA2, & - & PSPVOR,PSPDIV,PSPSCALAR,& - & PSPSC3A,PSPSC3B,PSPSC2 , & - & KFLDPTRUV,KFLDPTRSC) - -!**** *UPDSPAD* - Update spectral arrays after direct Legendre transform - -! Purpose. -! -------- -! To update the spectral arrays for a fixed zonal wave-number -! from values in POA1 and POA2. - -!** Interface. -! ---------- -! CALL UPDSPAD(...) - -! Explicit arguments : -! -------------------- -! KM - zonal wave-number -! POA1 - spectral fields for zonal wavenumber KM (basic var.) -! POA2 - spectral fields for zonal wavenumber KM (vor. div.) -! PSPVOR - spectral vorticity -! PSPDIV - spectral divergence -! PSPSCALAR - spectral scalar variables - -! Implicit arguments : -! -------------------- - -! Method. -! ------- - -! Externals. UPDSPADB - basic transfer routine -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 88-02-02 -! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite -! for uv formulation -! Modified : 94-08-02 R. El Khatib - interface to UPDSPADB -! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div -! instead of u,v->vor,div -! MPP Group: 95-10-01 Support for Distributed Memory version -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B -USE TPM_DISTR ,ONLY : D - -USE UPDSPBAD_MOD ,ONLY : UPDSPBAD -! - -IMPLICIT NONE - - -! DUMMY INTEGER SCALARS - -INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS - -REAL(KIND=JPRBT) , INTENT(OUT) :: POA1(:,:) -REAL(KIND=JPRBT) , INTENT(OUT) :: POA2(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) -REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) -INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND, JN, ISE,IFLD,JFLD -INTEGER(KIND=JPIM) :: IDIM1,IDIM3,J3 - -! ------------------------------------------------------------------ - -!* 1. UPDATE FIELDS -! ------------- - - -!* 1.1 VORTICITY AND DIVERGENCE. - -IST = 1 -IF (KF_UV > 0) THEN - IST = IST+4*KF_UV - IVORS = 1 - IVORE = 2*KF_UV - IDIVS = 2*KF_UV+1 - IDIVE = 4*KF_UV - IF (KM == 0) THEN - IF(PRESENT(KFLDPTRUV)) THEN - DO JFLD=1,KF_UV - IFLD = KFLDPTRUV(JFLD) - PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRBT - PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRBT - ENDDO - DO JN=0,R%NSMAX - ISE = 1+JN*2+1 - DO JFLD=1,KF_UV - IFLD = KFLDPTRUV(JFLD) - PSPDIV(IFLD,ISE) = 0.0_JPRBT - PSPVOR(IFLD,ISE) = 0.0_JPRBT - ENDDO - ENDDO - ELSE - PSPVOR(:,D%NASM0(0)) = 0.0_JPRBT - PSPDIV(:,D%NASM0(0)) = 0.0_JPRBT - DO JN=0,R%NSMAX - ISE = 1+JN*2+1 - PSPDIV(:,ISE) = 0.0_JPRBT - PSPVOR(:,ISE) = 0.0_JPRBT - ENDDO - ENDIF - ENDIF - CALL UPDSPBAD(KM,KF_UV,POA2(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) - CALL UPDSPBAD(KM,KF_UV,POA2(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) -ENDIF - -!* 1.2 SCALARS - -IF (KF_SCALARS > 0) THEN - IF(PRESENT(PSPSCALAR)) THEN - IEND = IST+2*KF_SCALARS-1 - CALL UPDSPBAD(KM,KF_SCALARS,POA1(:,IST:IEND),PSPSCALAR,KFLDPTRSC) - ELSE - IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN - IDIM1 = NF_SC2 - IEND = IST+2*IDIM1-1 - CALL UPDSPBAD(KM,IDIM1,POA1(:,IST:IEND),PSPSC2) - IST=IST+2*IDIM1 - ENDIF - IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN - IDIM1=NF_SC3A - IDIM3=UBOUND(PSPSC3A,3) - DO J3=1,IDIM3 - IEND = IST+2*IDIM1-1 - CALL UPDSPBAD(KM,IDIM1,POA1(:,IST:IEND),PSPSC3A(:,:,J3)) - IST=IST+2*IDIM1 - ENDDO - ENDIF - IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN - IDIM1=NF_SC3B - IDIM3=UBOUND(PSPSC3B,3) - DO J3=1,IDIM3 - IEND = IST+2*IDIM1-1 - CALL UPDSPBAD(KM,IDIM1,POA1(:,IST:IEND),PSPSC3B(:,:,J3)) - IST=IST+2*IDIM1 - ENDDO - ENDIF - ENDIF -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE UPDSPAD -END MODULE UPDSPAD_MOD diff --git a/src/trans/gpu/internal/updspb_mod.F90 b/src/trans/gpu/internal/updspb_mod.F90 index 8d66b5c7f..877895c45 100755 --- a/src/trans/gpu/internal/updspb_mod.F90 +++ b/src/trans/gpu/internal/updspb_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 1988- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -96,40 +97,26 @@ SUBROUTINE UPDSPB(KFIELD,POA,PSPEC,KFLDPTR) !loop over wavenumber !$ACC DATA PRESENT(PSPEC,POA,R,D) !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,IASM0,INM,IR,II) DEFAULT(NONE) - DO KMLOC=1,D%NUMP - DO JN=R%NTMAX+2-R%NSMAX,R%NTMAX+2 - DO JFLD=1,KFIELD - - KM = D%MYMS(KMLOC) - IASM0 = D%NASM0(KM) - - IF(KM == 0) THEN - - if (JN .le. R%NTMAX+2-KM) then - - INM = IASM0+(R%NTMAX+2-JN)*2 - IR = 2*JFLD-1 - PSPEC(JFLD,INM) = POA(IR,JN,KMLOC) - PSPEC(JFLD,INM+1) = 0.0_JPRBT - - end if - ELSE - - - if (JN .le. R%NTMAX+2-KM) then - INM = IASM0+((R%NTMAX+2-JN)-KM)*2 - - IR = 2*JFLD-1 - II = IR+1 - PSPEC(JFLD,INM) = POA(IR,JN,KMLOC) - PSPEC(JFLD,INM+1) = POA(II,JN,KMLOC) - - end if - end if - - ENDDO - ENDDO + DO KMLOC=1,D%NUMP + DO JN=3,R%NTMAX+3 + DO JFLD=1,KFIELD + KM = D%MYMS(KMLOC) + IASM0 = D%NASM0(KM) + + IF(KM /= 0 .AND. JN <= R%NTMAX+3-KM) THEN + !(DO JN=3,R%NTMAX+3-KM) + INM = IASM0+((R%NTMAX+3-JN)-KM)*2 + PSPEC(JFLD,INM) = POA(2*JFLD-1,JN,KMLOC) + PSPEC(JFLD,INM+1) = POA(2*JFLD ,JN,KMLOC) + ELSEIF (KM == 0) THEN + !(DO JN=3,R%NTMAX+3) + INM = IASM0+(R%NTMAX+3-JN)*2 + PSPEC(JFLD,INM) = POA(2*JFLD-1,JN,KMLOC) + PSPEC(JFLD,INM+1) = 0.0_JPRBT + END IF + ENDDO ENDDO + ENDDO !$ACC END PARALLEL !$ACC END DATA diff --git a/src/trans/gpu/internal/updspb_vd_mod.F90 b/src/trans/gpu/internal/updspb_vd_mod.F90 deleted file mode 100755 index 400990a11..000000000 --- a/src/trans/gpu/internal/updspb_vd_mod.F90 +++ /dev/null @@ -1,154 +0,0 @@ -! (C) Copyright 2000- 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 UPDSPB_VD_MOD -CONTAINS -SUBROUTINE UPDSPB_VD(KFIELD,PSPVOR,PSPDIV,KFLDPTR) - - !**** *UPDSPB* - Update spectral arrays after direct Legendre transform - - ! Purpose. - ! -------- - ! To update spectral arrays for a fixed zonal wave-number - ! from values in POA. - - !** Interface. - ! ---------- - ! CALL UPDSPB(....) - - ! Explicit arguments : KM - zonal wavenumber - ! -------------------- KFIELD - number of fields - ! POA - work array - ! PSPEC - spectral array - - ! Implicit arguments : None - ! -------------------- - - ! Method. - ! ------- - - ! Externals. - ! ---------- - - ! Reference. - ! ---------- - ! ECMWF Research Department documentation of the IFS - - ! Author. - ! ------- - ! Mats Hamrud and Philippe Courtier *ECMWF* - - ! Modifications. - ! -------------- - ! Original : 88-02-02 - ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) - ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the - ! first and last field - ! L. Isaksen : 95-06-06 Reordering of spectral arrays - ! ------------------------------------------------------------------ - - USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - - - - USE TPM_DIM ,ONLY : R,R_NSMAX,R_NTMAX - USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS,D_NASM0 - USE TPM_FIELDS ,ONLY : ZOA2 - ! - - IMPLICIT NONE - - INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD - INTEGER(KIND=JPIM) :: KM,KMLOC - REAL(KIND=JPRB) ,INTENT(OUT) :: PSPVOR(:,:) - REAL(KIND=JPRB) ,INTENT(OUT) :: PSPDIV(:,:) - INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) - - ! LOCAL INTEGER SCALARS - INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN, ISMAX, ITMAX, IASM0,IFLD - INTEGER(KIND=JPIM) :: IVORS, IDIVS - - - ! ------------------------------------------------------------------ - - !* 0. NOTE. - ! ----- - - ! The following transfer reads : - ! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) - ! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) - ! with n from m to NSMAX - ! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. - ! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) - ! nn is the loop index. - - IVORS = 1 - IDIVS = 2*KFIELD+1 - - !* 1. UPDATE SPECTRAL FIELDS. - ! ----------------------- - !$ACC data & - !$ACC& present(ZOA2) & - !$ACC& copy(PSPVOR,PSPDIV) & - !$ACC& copy(D,D_NUMP,D_MYMS,R,R_NSMAX,R_NTMAX,D,D_NASM0) - - !$ACC parallel loop collapse(3) private(KM,INM,IR,II,IASM0,IFLD) - DO KMLOC=1,D_NUMP - DO JN=R_NTMAX+2-R_NSMAX,R_NTMAX+2 - DO JFLD=1,KFIELD - - KM = D_MYMS(KMLOC) - IASM0 = D_NASM0(KM) - - IF(KM == 0) THEN - - if (JN .le. R_NTMAX+2-KM) then - INM = IASM0+(R_NTMAX+2-JN)*2 - IR = 2*JFLD-1 - PSPVOR(JFLD,INM) = ZOA2(IVORS+IR-1,JN,KMLOC) - PSPDIV(JFLD,INM) = ZOA2(IDIVS+IR-1,JN,KMLOC) - PSPVOR(JFLD,INM+1) = 0.0_JPRBT - PSPDIV(JFLD,INM+1) = 0.0_JPRBT - end if - IF(PRESENT(KFLDPTR)) THEN - IFLD = KFLDPTR(JFLD) - PSPVOR(IFLD,IASM0) = 0.0_JPRBT - PSPDIV(IFLD,IASM0) = 0.0_JPRBT - ELSE - PSPVOR(JFLD,IASM0) = 0.0_JPRBT - PSPDIV(JFLD,IASM0) = 0.0_JPRBT - ENDIF - - ELSE - - - if (JN .le. R_NTMAX+2-KM) then - INM = IASM0+((R_NTMAX+2-JN)-KM)*2 - - IR = 2*JFLD-1 - II = IR+1 - PSPVOR(JFLD,INM) = ZOA2(IVORS+IR-1,JN,KMLOC) - PSPVOR(JFLD,INM+1) = ZOA2(IVORS+II-1,JN,KMLOC) - PSPDIV(JFLD,INM) = ZOA2(IDIVS+IR-1,JN,KMLOC) - PSPDIV(JFLD,INM+1) = ZOA2(IDIVS+II-1,JN,KMLOC) - - end if - end if - - ENDDO - - ENDDO - !end loop over wavenumber - END DO - !$ACC end data - - ! ------------------------------------------------------------------ - - END SUBROUTINE UPDSPB_VD - END MODULE UPDSPB_VD_MOD diff --git a/src/trans/gpu/internal/updspbad_mod.F90 b/src/trans/gpu/internal/updspbad_mod.F90 deleted file mode 100755 index 0806c62ab..000000000 --- a/src/trans/gpu/internal/updspbad_mod.F90 +++ /dev/null @@ -1,159 +0,0 @@ -! (C) Copyright 1988- 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 UPDSPBAD_MOD -CONTAINS -SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) - - -!**** *UPDSPBAD* - Update spectral arrays after direct Legendre transform - -! Purpose. -! -------- -! To update spectral arrays for a fixed zonal wave-number -! from values in POA. - -!** Interface. -! ---------- -! CALL UPDSPBAD(....) - -! Explicit arguments : KM - zonal wavenumber -! -------------------- KFIELD - number of fields -! POA - work array -! PSPEC - spectral array - -! Implicit arguments : None -! -------------------- - -! Method. -! ------- - -! Externals. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 88-02-02 -! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) -! R. El Khatib : 94-08-02 Replace number of fields by indexes of the -! first and last field -! L. Isaksen : 95-06-06 Reordering of spectral arrays -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_DIM ,ONLY : R -!USE TPM_FIELDS -USE TPM_DISTR ,ONLY : D -! - -IMPLICIT NONE -INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD -REAL(KIND=JPRBT) ,INTENT(OUT) :: POA(:,:) -REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) -INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN, ISMAX, ITMAX, IASM0,IFLD - - -! ------------------------------------------------------------------ - -!* 0. NOTE. -! ----- - -! The following transfer reads : -! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) -! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) -! with n from m to NSMAX -! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. -! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) -! nn is the loop index. - - - -!* 1. UPDATE SPECTRAL FIELDS. -! ----------------------- -ISMAX = R%NSMAX -ITMAX = R%NTMAX -IASM0 = D%NASM0(KM) - - -POA(:,:) = 0.0_JPRBT - -!* 1.1 KM=0 - -IF(KM == 0) THEN - IF(PRESENT(KFLDPTR)) THEN - DO JFLD=1,KFIELD - IR = 2*JFLD-1 - IFLD = KFLDPTR(JFLD) - DO JN=ITMAX+2-ISMAX,ITMAX+2-KM - INM = IASM0+(ITMAX+2-JN)*2 - POA(JN,IR) = PSPEC(IFLD,INM) - PSPEC(IFLD,INM) = 0.0_JPRBT - ENDDO - ENDDO - ELSE - DO JN=ITMAX+2-ISMAX,ITMAX+2-KM - INM = IASM0+(ITMAX+2-JN)*2 -!DIR$ IVDEP -!OCL NOVREC - DO JFLD=1,KFIELD - IR = 2*JFLD-1 - POA(JN,IR) = PSPEC(JFLD,INM) - PSPEC(JFLD,INM) = 0.0_JPRBT - ENDDO - ENDDO - ENDIF -!* 1.2 KM!=0 - -ELSE - IF(PRESENT(KFLDPTR)) THEN - DO JFLD=1,KFIELD - IR = 2*JFLD-1 - II = IR+1 - IFLD = KFLDPTR(JFLD) - DO JN=ITMAX+2-ISMAX,ITMAX+2-KM - INM = IASM0+((ITMAX+2-JN)-KM)*2 - POA(JN,IR) = PSPEC(IFLD,INM) - POA(JN,II) = PSPEC(IFLD,INM+1) - PSPEC(IFLD,INM) = 0.0_JPRBT - PSPEC(IFLD,INM+1) = 0.0_JPRBT - ENDDO - ENDDO - ELSE - DO JN=ITMAX+2-ISMAX,ITMAX+2-KM - INM = IASM0+((ITMAX+2-JN)-KM)*2 -!DIR$ IVDEP -!OCL NOVREC - DO JFLD=1,KFIELD - IR = 2*JFLD-1 - II = IR+1 - POA(JN,IR) = PSPEC(JFLD,INM) - POA(JN,II) = PSPEC(JFLD,INM+1) - PSPEC(JFLD,INM) = 0.0_JPRBT - PSPEC(JFLD,INM+1) = 0.0_JPRBT - ENDDO - ENDDO - ENDIF -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE UPDSPBAD -END MODULE UPDSPBAD_MOD diff --git a/src/trans/gpu/internal/uvtvd_mod.F90 b/src/trans/gpu/internal/uvtvd_mod.F90 index 0c7c79f6e..7527aee70 100755 --- a/src/trans/gpu/internal/uvtvd_mod.F90 +++ b/src/trans/gpu/internal/uvtvd_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 1991- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -9,8 +10,7 @@ MODULE UVTVD_MOD CONTAINS -SUBROUTINE UVTVD(KFIELD) -!SUBROUTINE UVTVD(KFIELD,PEPSNM,PU,PV,PVOR,PDIV) +SUBROUTINE UVTVD(KF_UV,PU,PV,PVOR,PDIV) !**** *UVTVD* - Compute vor/div from u and v in spectral space @@ -22,10 +22,10 @@ SUBROUTINE UVTVD(KFIELD) !** Interface. ! ---------- -! CALL UVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) +! CALL UVTVD(KM,KF_UV,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number -! -------------------- KFIELD - number of fields (levels) +! -------------------- KF_UV - number of fields (levels) ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM @@ -62,106 +62,87 @@ SUBROUTINE UVTVD(KFIELD) USE TPM_DIM ,ONLY : R, R_NTMAX USE TPM_FIELDS ,ONLY : F USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS -USE TPM_FIELDS ,ONLY : ZOA1,ZOA2,ZEPSNM +USE TPM_FIELDS ,ONLY : ZEPSNM ! IMPLICIT NONE ! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD +INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM) :: KM, KMLOC -!REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(1:d%nump,0:R%NTMAX+2) -!REAL(KIND=JPRBT), INTENT(OUT) :: PVOR(:,:,:),PDIV(:,:,:) -!REAL(KIND=JPRBT), INTENT(INOUT) :: PU (:,:,:),PV (:,:,:) +REAL(KIND=JPRBT), INTENT(OUT) :: PVOR(:,:,:),PDIV(:,:,:) +REAL(KIND=JPRBT), INTENT(INOUT) :: PU (:,:,:),PV (:,:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IN, IR, J, JN, ITMAX -INTEGER(KIND=JPIM) :: IUS, IUE, IVS, IVE, IVORS, IVORE, IDIVS, IDIVE ! LOCAL REAL SCALARS -REAL(KIND=JPRBT) :: ZKM -REAL(KIND=JPRBT) :: ZN(-1:R%NTMAX+3) -REAL(KIND=JPRBT), POINTER :: PU(:,:,:),PV(:,:,:),PVOR(:,:,:),PDIV(:,:,:) - -IUS = 1 -IUE = 2*KFIELD -IVS = 2*KFIELD+1 -IVE = 4*KFIELD -IVORS = 1 -IVORE = 2*KFIELD -IDIVS = 2*KFIELD+1 -IDIVE = 4*KFIELD +REAL(KIND=JPRBT) :: ZKM,ZJN ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ -PU => ZOA1(IUS:IUE,:,:) -PV => ZOA1(IVS:IVE,:,:) -PVOR => ZOA2(IVORS:IVORE,:,:) -PDIV => ZOA2(IDIVS:IDIVE,:,:) - !$ACC DATA& -!$ACC& CREATE(ZN) & -!$ACC& COPY(D_MYMS,D_NUMP,R_NTMAX) & -!$ACC& COPY(F,F%RN,F%NLTN) & +!$ACC& PRESENT(D_MYMS) & +!$ACC& PRESENT(F,F%RN,F%NLTN) & !$ACC& PRESENT(ZEPSNM,PU,PV,PVOR,PDIV) -!$ACC PARALLEL LOOP DEFAULT(NONE) -DO J=-1,R_NTMAX+3 - ZN(j) = F%RN(j) -ENDDO !* 1.1 SET N=KM-1 COMPONENT TO 0 FOR U AND V -!$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IN) DEFAULT(NONE) +!$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM) DEFAULT(NONE) DO KMLOC=1,D_NUMP - DO J=1,2*KFIELD + DO J=1,2*KF_UV KM = D_MYMS(KMLOC) - IN = F%NLTN(KM-1) -! IN=R_NTMAX+3-KM - PU(J,IN,KMLOC) = 0.0_JPRBT - PV(J,IN,KMLOC) = 0.0_JPRBT + PU(J,R_NTMAX+4-KM,KMLOC) = 0.0_JPRBT + PV(J,R_NTMAX+4-KM,KMLOC) = 0.0_JPRBT ENDDO ENDDO !* 1.2 COMPUTE VORTICITY AND DIVERGENCE. -!$ACC parallel loop collapse(3) private(IR,II,IN,KM,ZKM) DEFAULT(NONE) +!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IR,II,IN,KM,ZKM,JN,ZJN) DEFAULT(NONE) DO KMLOC=1,D_NUMP DO JN=0,R_NTMAX - DO J=1,KFIELD + DO J=1,KF_UV IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) ZKM = REAL(KM,JPRBT) - IN = R_NTMAX+2-JN - - IF(KM /= 0 .and. JN.GE.KM) THEN - PVOR(IR,IN,kmloc) = -ZKM*PV(II,IN,kmloc)-& - &ZN(JN)*ZEPSNM(KMLOC,JN+1)*PU(IR,IN-1,kmloc)+& - &ZN(JN+1)*ZEPSNM(KMLOC,JN)*PU(IR,IN+1,kmloc) - PVOR(II,IN,kmloc) = +ZKM*PV(IR,IN,kmloc)-& - &ZN(JN)*ZEPSNM(KMLOC,JN+1)*PU(II,IN-1,kmloc)+& - &ZN(JN+1)*ZEPSNM(KMLOC,JN)*PU(II,IN+1,kmloc) - PDIV(IR,IN,kmloc) = -ZKM*PU(II,IN,kmloc)+& - &ZN(JN)*ZEPSNM(KMLOC,JN+1)*PV(IR,IN-1,kmloc)-& - &ZN(JN+1)*ZEPSNM(KMLOC,JN)*PV(IR,IN+1,kmloc) - PDIV(II,IN,kmloc) = +ZKM*PU(IR,IN,kmloc)+& - &ZN(JN)*ZEPSNM(KMLOC,JN+1)*PV(II,IN-1,kmloc)-& - &ZN(JN+1)*ZEPSNM(KMLOC,JN)*PV(II,IN+1,kmloc) - ELSE - IF(KM == 0) THEN - PVOR(IR,IN,kmloc) = -& - &ZN(JN)*ZEPSNM(KMLOC,JN+1)*PU(IR,IN-1,kmloc)+& - &ZN(JN+1)*ZEPSNM(KMLOC,JN)*PU(IR,IN+1,kmloc) - PDIV(IR,IN,kmloc) = & - &ZN(JN)*ZEPSNM(KMLOC,JN+1)*PV(IR,IN-1,kmloc)-& - &ZN(JN+1)*ZEPSNM(KMLOC,JN)*PV(IR,IN+1,kmloc) - ENDIF + + IF(KM /= 0 .AND. JN >= KM) THEN + ! (DO JN=KN,R_NTMAX) + IN = R_NTMAX+3-JN + ZJN = JN + + PVOR(IR,IN,kmloc) = -ZKM*PV(II,IN,kmloc)-& + &ZJN*ZEPSNM(KMLOC,JN+1)*PU(IR,IN-1,kmloc)+& + &(ZJN+1)*ZEPSNM(KMLOC,JN)*PU(IR,IN+1,kmloc) + PVOR(II,IN,kmloc) = +ZKM*PV(IR,IN,kmloc)-& + &ZJN*ZEPSNM(KMLOC,JN+1)*PU(II,IN-1,kmloc)+& + &(ZJN+1)*ZEPSNM(KMLOC,JN)*PU(II,IN+1,kmloc) + PDIV(IR,IN,kmloc) = -ZKM*PU(II,IN,kmloc)+& + &ZJN*ZEPSNM(KMLOC,JN+1)*PV(IR,IN-1,kmloc)-& + &(ZJN+1)*ZEPSNM(KMLOC,JN)*PV(IR,IN+1,kmloc) + PDIV(II,IN,kmloc) = +ZKM*PU(IR,IN,kmloc)+& + &ZJN*ZEPSNM(KMLOC,JN+1)*PV(II,IN-1,kmloc)-& + &(ZJN+1)*ZEPSNM(KMLOC,JN)*PV(II,IN+1,kmloc) + + ELSEIF(KM == 0) THEN + ! (DO JN=0,R_NTMAX) + IN = R_NTMAX+3-JN + ZJN = JN + + PVOR(IR,IN,kmloc) = -& + &ZJN*ZEPSNM(KMLOC,JN+1)*PU(IR,IN-1,kmloc)+& + &(ZJN+1)*ZEPSNM(KMLOC,JN)*PU(IR,IN+1,kmloc) + PDIV(IR,IN,kmloc) = & + &ZJN*ZEPSNM(KMLOC,JN+1)*PV(IR,IN-1,kmloc)-& + &(ZJN+1)*ZEPSNM(KMLOC,JN)*PV(IR,IN+1,kmloc) ENDIF - ENDDO + ENDDO ENDDO ENDDO !$acc end data diff --git a/src/trans/gpu/internal/uvtvdad_mod.F90 b/src/trans/gpu/internal/uvtvdad_mod.F90 deleted file mode 100755 index c01aaa34d..000000000 --- a/src/trans/gpu/internal/uvtvdad_mod.F90 +++ /dev/null @@ -1,138 +0,0 @@ -! (C) Copyright 1991- 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 UVTVDAD_MOD -CONTAINS -SUBROUTINE UVTVDAD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) - -!**** *UVTVDAD* - Compute vor/div from u and v in spectral space - -! Purpose. -! -------- -! To compute vorticity and divergence from u and v in spectral -! space. Input u and v from KM to NTMAX+1, output vorticity and -! divergence from KM to NTMAX. - -!** Interface. -! ---------- -! CALL UVTVDAD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) - -! Explicit arguments : KM - zonal wave-number -! -------------------- KFIELD - number of fields (levels) -! PEPSNM - REPSNM for wavenumber KM -! PU - u wind component for zonal -! wavenumber KM -! PV - v wind component for zonal -! wavenumber KM -! PVOR - vorticity for zonal -! wavenumber KM -! PDIV - divergence for zonal -! wavenumber KM - - -! Method. See ref. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 91-07-01 -! D. Giard : NTMAX instead of NSMAX -! ------------------------------------------------------------------ - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_FIELDS ,ONLY : F -!USE TPM_DISTR -! - -IMPLICIT NONE - -! DUMMY INTEGER SCALARS -INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD -INTEGER(KIND=JPIM), INTENT(IN) :: KM - -REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) -REAL(KIND=JPRBT), INTENT(IN) :: PVOR(:,:),PDIV(:,:) -REAL(KIND=JPRBT), INTENT(INOUT) :: PU (:,:),PV (:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: II, IN, IR, J, JN, ITMAX - -! LOCAL REAL SCALARS -REAL(KIND=JPRBT) :: ZKM -REAL(KIND=JPRBT) :: ZN(-1:R%NTMAX+3) - - -! ------------------------------------------------------------------ - - -!* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. -! ------------------------------------------ - -ZKM = KM -ITMAX = R%NTMAX -ZN(KM-1:ITMAX+3) = F%RN(KM-1:ITMAX+3) - -!* 1.2 COMPUTE VORTICITY AND DIVERGENCE. - -IF(KM /= 0) THEN - DO JN=KM,ITMAX - IN = ITMAX+2-JN -!DIR$ IVDEP -!OCL NOVREC - DO J=1,KFIELD - IR = 2*J-1 - II = IR+1 - - PV(IN,II) = PV(IN,II)-ZKM*PVOR(IN,IR) - PU(IN-1,IR) = PU(IN-1,IR)-ZN(JN)*PEPSNM(JN+1)*PVOR(IN,IR) - PU(IN+1,IR) = PU(IN+1,IR)+ZN(JN+1)*PEPSNM(JN)*PVOR(IN,IR) - - PV(IN,IR) = PV(IN,IR)+ZKM*PVOR(IN,II) - PU(IN-1,II) = PU(IN-1,II)-ZN(JN)*PEPSNM(JN+1)*PVOR(IN,II) - PU(IN+1,II) = PU(IN+1,II)+ZN(JN+1)*PEPSNM(JN)*PVOR(IN,II) - - PU(IN,II) = PU(IN,II)-ZKM*PDIV(IN,IR) - PV(IN-1,IR) = PV(IN-1,IR)+ZN(JN)*PEPSNM(JN+1)*PDIV(IN,IR) - PV(IN+1,IR) = PV(IN+1,IR)-ZN(JN+1)*PEPSNM(JN)*PDIV(IN,IR) - - PU(IN,IR) = PU(IN,IR)+ZKM*PDIV(IN,II) - PV(IN-1,II) = PV(IN-1,II)+ZN(JN)*PEPSNM(JN+1)*PDIV(IN,II) - PV(IN+1,II) = PV(IN+1,II)-ZN(JN+1)*PEPSNM(JN)*PDIV(IN,II) - ENDDO - ENDDO -ELSE - DO JN=KM,ITMAX - IN = ITMAX+2-JN - DO J=1,KFIELD - IR = 2*J-1 - PU(IN-1,IR) = PU(IN-1,IR)-ZN(JN )*PEPSNM(JN+1)*PVOR(IN,IR) - PU(IN+1,IR) = PU(IN+1,IR)+ZN(JN+1)*PEPSNM(JN )*PVOR(IN,IR) - PV(IN-1,IR) = PV(IN-1,IR)+ZN(JN )*PEPSNM(JN+1)*PDIV(IN,IR) - PV(IN+1,IR) = PV(IN+1,IR)-ZN(JN+1)*PEPSNM(JN )*PDIV(IN,IR) - ENDDO - ENDDO -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE UVTVDAD -END MODULE UVTVDAD_MOD diff --git a/src/trans/gpu/internal/vd2uv_ctl_mod.F90 b/src/trans/gpu/internal/vd2uv_ctl_mod.F90 deleted file mode 100755 index 08ec2a971..000000000 --- a/src/trans/gpu/internal/vd2uv_ctl_mod.F90 +++ /dev/null @@ -1,80 +0,0 @@ -! (C) Copyright 2015- 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 VD2UV_CTL_MOD -CONTAINS -SUBROUTINE VD2UV_CTL(KF_UV,PSPVOR,PSPDIV,PU,PV) - -!**** *VD2UV_CTL* - Control routine for going from vor/div to spectral U and V. - -! Purpose. -! -------- -! Control routine for computing spectral U (u*cos(theta)) and V - -!** Interface. -! ---------- -! CALL INV_TRANS_CTL(...) -! KF_UV - local number of spectral u-v fields -! PSPVOR(:,:) - spectral vorticity (input) -! PSPDIV(:,:) - spectral divergence (input) -! PU(:,:) - U (out) -! PV(:,:) - V (out) - -! Method. -! ------- - -! Externals. -! ---------- - - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : July 2015 - -! ------------------------------------------------------------------ - -USE PARKIND1 ,ONLY : JPIM ,JPRB - -USE TPM_DISTR ,ONLY : D - -USE VD2UV_MOD ,ONLY : VD2UV - -IMPLICIT NONE - -INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV -REAL(KIND=JPRB),INTENT(IN) :: PSPVOR(:,:) -REAL(KIND=JPRB),INTENT(IN) :: PSPDIV(:,:) -REAL(KIND=JPRB),INTENT(OUT) :: PU(:,:) -REAL(KIND=JPRB),INTENT(OUT) :: PV(:,:) - -INTEGER(KIND=JPIM) :: JM,IM,ILEI2 - -! ------------------------------------------------------------------ - -CALL GSTATS(102,0) -ILEI2 = 8*KF_UV - -CALL GSTATS(1647,0) -!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) -DO JM=1,D%NUMP - IM = D%MYMS(JM) - CALL VD2UV(IM,JM,KF_UV,ILEI2,PSPVOR,PSPDIV,PU,PV) -ENDDO -!$OMP END PARALLEL DO -CALL GSTATS(1647,1) -CALL GSTATS(102,1) - -! ------------------------------------------------------------------ - -END SUBROUTINE VD2UV_CTL -END MODULE VD2UV_CTL_MOD diff --git a/src/trans/gpu/internal/vd2uv_mod.F90 b/src/trans/gpu/internal/vd2uv_mod.F90 deleted file mode 100755 index b97c49f22..000000000 --- a/src/trans/gpu/internal/vd2uv_mod.F90 +++ /dev/null @@ -1,156 +0,0 @@ -! (C) Copyright 2015- 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 VD2UV_MOD -CONTAINS -SUBROUTINE VD2UV(KM,KMLOC,KF_UV,KLEI2,PSPVOR,PSPDIV,PU,PV) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT -USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK - -USE TPM_CONSTANTS -USE TPM_DIM ,ONLY : R -USE TPM_DISTR ,ONLY : D - -USE PREPSNM_MOD ,ONLY : PREPSNM -USE PRFI1B_MOD ,ONLY : PRFI1B -USE VDTUV_MOD ,ONLY : VDTUV - - -!**** *VD2UV* - U and V from Vor/div -! -! Purpose. -! -------- -! -!** Interface. -! ---------- -! *CALL* *VD2UV(...) - -! Explicit arguments : -! -------------------- -! KM - zonal wavenumber -! KMLOC - local zonal wavenumber -! PSPVOR - spectral vorticity -! PSPDIV - spectral divergence -! PU(:,:) - spectral U (out) -! PV(:,:) - spectral V (out) - - -! Implicit arguments : - -! Method. -! ------- - -! Externals. -! ---------- - -! PREPSNM - prepare REPSNM for wavenumber KM -! PRFI1B - prepares the spectral fields -! VDTUV - compute u and v from vorticity and divergence - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS -! Temperton, 1991, MWR 119 p1303 - -! Author. -! ------- -! Mats Hamrud *ECMWF* - -! Modifications. -! -------------- -! Original : July 2015 -! -! ------------------------------------------------------------------ - -IMPLICIT NONE - -INTEGER(KIND=JPIM), INTENT(IN) :: KM -INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC -INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV -INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 - -REAL(KIND=JPRB) , INTENT(IN) :: PSPVOR(:,:) -REAL(KIND=JPRB) , INTENT(IN) :: PSPDIV(:,:) -REAL(KIND=JPRB) , INTENT(OUT) :: PU(:,:) -REAL(KIND=JPRB) , INTENT(OUT) :: PV(:,:) - -REAL(KIND=JPRB) :: ZIA(R%NLEI1,KLEI2) -REAL(KIND=JPRBT) :: ZEPSNM(0:R%NTMAX+2),ZA_R - -INTEGER(KIND=JPIM) :: IFC, ISTA, IIFC, IDGLU, JGL, JFLD,ILCM -INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,II,IR,INM,J -INTEGER(KIND=JPIM) :: IFIRST, ILAST, IOFF - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ------------------------------------------------------------------ - -!* 1. PERFORM LEGENDRE TRANFORM. -! -------------------------- - -IF (LHOOK) CALL DR_HOOK('VD2UV_MOD',0,ZHOOK_HANDLE) - -! ------------------------------------------------------------------ - -!* 1. PREPARE ZEPSNM. -! --------------- - -stop 'Error: code path not (yet) supported in GPU version' -!CALL PREPSNM(KM,KMLOC,ZEPSNM) - -! ------------------------------------------------------------------ - - -!* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. -! ---------------------------------------------- - -IFIRST = 1 -ILAST = 4*KF_UV - -IF (KF_UV > 0) THEN - IVORL = 1 - IVORU = 2*KF_UV - IDIVL = 2*KF_UV+1 - IDIVU = 4*KF_UV - IUL = 4*KF_UV+1 - IUU = 6*KF_UV - IVL = 6*KF_UV+1 - IVU = 8*KF_UV - stop 'Error: code path not (yet) supported in GPU version' - !CALL PRFI1B(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV) - !CALL PRFI1B(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV) - - !CALL VDTUV(KM,KF_UV,ZEPSNM,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& - ! & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU)) - ILCM = R%NSMAX+1-KM - IOFF = D%NASM0(KM) - ZA_R = 1.0_JPRBT/RA - DO J=1,ILCM - INM = IOFF+(ILCM-J)*2 - DO JFLD=1,KF_UV - IR = 2*(JFLD-1)+1 - II = IR+1 - PU(JFLD,INM ) = ZIA(J+2,IR+IUL-1)*ZA_R - PU(JFLD,INM+1) = ZIA(J+2,II+IUL-1)*ZA_R - PV(JFLD,INM ) = ZIA(J+2,IR+IVL-1)*ZA_R - PV(JFLD,INM+1) = ZIA(J+2,II+IVL-1)*ZA_R - ENDDO - ENDDO -ENDIF - -IF (LHOOK) CALL DR_HOOK('VD2UV_MOD',1,ZHOOK_HANDLE) -! ------------------------------------------------------------------ - -END SUBROUTINE VD2UV -END MODULE VD2UV_MOD - - - - diff --git a/src/trans/gpu/internal/vdtuv_mod.F90 b/src/trans/gpu/internal/vdtuv_mod.F90 index bb74bf375..96387f850 100755 --- a/src/trans/gpu/internal/vdtuv_mod.F90 +++ b/src/trans/gpu/internal/vdtuv_mod.F90 @@ -1,4 +1,5 @@ ! (C) Copyright 2000- ECMWF. +! (C) Copyright 2022- NVIDIA. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. @@ -13,7 +14,7 @@ SUBROUTINE VDTUV(KFIELD,PEPSNM,PVOR,PDIV,PU,PV) USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT -USE TPM_DIM ,ONLY : R +USE TPM_DIM ,ONLY : R, R_NTMAX USE TPM_FIELDS ,ONLY : F USE TPM_DISTR ,ONLY : D,D_NUMP,D_MYMS use tpm_gen, only: nout @@ -77,23 +78,19 @@ SUBROUTINE VDTUV(KFIELD,PEPSNM,PVOR,PDIV,PU,PV) INTEGER(KIND=JPIM) :: KM, kmloc INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(1:D%NUMP,0:R%NTMAX+2) -REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:,:),PDIV(:,:,:) +REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:,:),PDIV(:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: PU (:,:,:),PV (:,:,:) ! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, ISMAX,JI +INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, JI ! LOCAL REAL SCALARS REAL(KIND=JPRBT) :: ZKM -REAL(KIND=JPRBT) :: ZN(-1:R%NTMAX+4) -REAL(KIND=JPRBT) :: ZLAPIN(-1:R%NSMAX+4) -REAL(KIND=JPRBT) :: ZEPSNM(-1:R%NSMAX+4) !$ACC DATA & -!$ACC CREATE (ZEPSNM, ZN, ZLAPIN) & -!$ACC COPYIN (D,D%MYMS,F,F%RLAPIN,F%RN) & +!$ACC PRESENT(D,D%MYMS,F,F%RLAPIN,F%RN) & !$ACC PRESENT(PEPSNM, PVOR, PDIV) & -!$ACC PRESENT(PU, PV) +!$ACC PRESENT(PU, PV, D_MYMS) ! ------------------------------------------------------------------ @@ -101,65 +98,45 @@ SUBROUTINE VDTUV(KFIELD,PEPSNM,PVOR,PDIV,PU,PV) !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ -ISMAX = R%NSMAX +!$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IR,II,KM,ZKM,JI) DEFAULT(NONE) DO KMLOC=1,D%NUMP - ZKM = D%MYMS(KMLOC) - !$ACC PARALLEL LOOP DEFAULT(NONE) - DO JN=ZKM-1,ISMAX+2 - IJ = ISMAX+3-JN - ZN(IJ) = F%RN(JN) - ZLAPIN(IJ) = F%RLAPIN(JN) - IF( JN >= 0 ) THEN - ZEPSNM(IJ) = PEPSNM(KMLOC,JN) - ELSE - ZEPSNM(IJ) = 0 - ENDIF - ENDDO - !$ACC KERNELS DEFAULT(NONE) - ZN(0) = F%RN(ISMAX+3) - !$ACC END KERNELS - -!* 1.1 U AND V (KM=0) . - -IF(ZKM == 0) THEN - !$ACC PARALLEL LOOP DEFAULT(NONE) - DO J=1,KFIELD - IR = 2*J-1 - DO JI=2,ISMAX+3 - PU(IR,JI,KMLOC) = +& - &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PVOR(IR,JI+1,KMLOC)-& - &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PVOR(IR,JI-1,KMLOC) - PV(IR,JI,KMLOC) = -& - &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PDIV(IR,JI+1,KMLOC)+& - &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PDIV(IR,JI-1,KMLOC) - ENDDO - ENDDO -ELSE -!* 1.2 U AND V (KM!=0) . - - !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) + DO JN=0,R_NTMAX+1 DO J=1,KFIELD - DO JI=2,ISMAX+3-ZKM - !ZKM = D_MYMS(KMLOC) - IR = 2*J-1 - II = IR+1 - !IF (ZKM>0 .AND. JI<=ISMAX+3-zKM) THEN - PU(ir,JI,kmloc) = -ZKM*ZLAPIN(JI)*PDIV(ii,JI,kmloc)+& - &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PVOR(ir,JI+1,kmloc)-& - &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PVOR(ir,JI-1,kmloc) - PU(ii,JI,kmloc) = +ZKM*ZLAPIN(JI)*PDIV(ir,JI,kmloc)+& - &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PVOR(ii,JI+1,kmloc)-& - &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PVOR(ii,JI-1,kmloc) - PV(ir,JI,kmloc) = -ZKM*ZLAPIN(JI)*PVOR(ii,JI,kmloc)-& - &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PDIV(ir,JI+1,kmloc)+& - &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PDIV(ir,JI-1,kmloc) - PV(ii,JI,kmloc) = +ZKM*ZLAPIN(JI)*PVOR(ir,JI,kmloc)-& - &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PDIV(ii,JI+1,kmloc)+& - &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PDIV(ii,JI-1,kmloc) - !ENDIF - ENDDO + IR = 2*J-1 + II = IR+1 + KM = D_MYMS(KMLOC) + ZKM = REAL(KM,JPRBT) + + IF(KM /= 0 .AND. JN >= KM) THEN + ! (DO JN=KN,R_NTMAX) + JI = R_NTMAX+3-JN + + PU(ir,JI,kmloc) = -ZKM*F%RLAPIN(JN)*PDIV(ii,JI,kmloc)+& + &(JN-1)*PEPSNM(KMLOC,JN)*F%RLAPIN(JN-1)*PVOR(ir,JI+1,kmloc)-& + &(JN+2)*PEPSNM(KMLOC,JN+1)*F%RLAPIN(JN+1)*PVOR(ir,JI-1,kmloc) + PU(ii,JI,kmloc) = +ZKM*F%RLAPIN(JN)*PDIV(ir,JI,kmloc)+& + &(JN-1)*PEPSNM(KMLOC,JN)*F%RLAPIN(JN-1)*PVOR(ii,JI+1,kmloc)-& + &(JN+2)*PEPSNM(KMLOC,JN+1)*F%RLAPIN(JN+1)*PVOR(ii,JI-1,kmloc) + PV(ir,JI,kmloc) = -ZKM*F%RLAPIN(JN)*PVOR(ii,JI,kmloc)-& + &(JN-1)*PEPSNM(KMLOC,JN)*F%RLAPIN(JN-1)*PDIV(ir,JI+1,kmloc)+& + &(JN+2)*PEPSNM(KMLOC,JN+1)*F%RLAPIN(JN+1)*PDIV(ir,JI-1,kmloc) + PV(ii,JI,kmloc) = +ZKM*F%RLAPIN(JN)*PVOR(ir,JI,kmloc)-& + &(JN-1)*PEPSNM(KMLOC,JN)*F%RLAPIN(JN-1)*PDIV(ii,JI+1,kmloc)+& + &(JN+2)*PEPSNM(KMLOC,JN+1)*F%RLAPIN(JN+1)*PDIV(ii,JI-1,kmloc) + + ELSEIF(KM == 0) THEN + ! (DO JN=0,R_NTMAX) + JI = R_NTMAX+3-JN + + PU(IR,JI,KMLOC) = +& + &(JN-1)*PEPSNM(KMLOC,JN)*F%RLAPIN(JN-1)*PVOR(IR,JI+1,KMLOC)-& + &(JN+2)*PEPSNM(KMLOC,JN+1)*F%RLAPIN(JN+1)*PVOR(IR,JI-1,KMLOC) + PV(IR,JI,KMLOC) = -& + &(JN-1)*PEPSNM(KMLOC,JN)*F%RLAPIN(JN-1)*PDIV(IR,JI+1,KMLOC)+& + &(JN+2)*PEPSNM(KMLOC,JN+1)*F%RLAPIN(JN+1)*PDIV(IR,JI-1,KMLOC) + ENDIF ENDDO - ENDIF + ENDDO ENDDO !$ACC END DATA diff --git a/src/trans/gpu/internal/vdtuvad_mod.F90 b/src/trans/gpu/internal/vdtuvad_mod.F90 deleted file mode 100755 index 8a6ec4b42..000000000 --- a/src/trans/gpu/internal/vdtuvad_mod.F90 +++ /dev/null @@ -1,144 +0,0 @@ -! (C) Copyright 2000- 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 VDTUVAD_MOD -CONTAINS -SUBROUTINE VDTUVAD(KM,KFIELD,PEPSNM,PVOR,PDIV,PU,PV) - -USE PARKIND_ECTRANS ,ONLY : JPIM ,JPRB, JPRBT - -USE TPM_DIM ,ONLY : R -USE TPM_FIELDS ,ONLY : F - - -!**** *VDTUVAD* - Compute U,V in spectral space - -! Purpose. -! -------- -! In Laplace space compute the the winds -! from vorticity and divergence. - -!** Interface. -! ---------- -! CALL VDTUVAD(...) - -! Explicit arguments : KM -zonal wavenumber (input-c) -! -------------------- KFIELD - number of fields (input-c) -! PEPSNM - REPSNM for wavenumber KM (input-c) -! PVOR(NLEI1,2*KFIELD) - vorticity (input) -! PDIV(NLEI1,2*KFIELD) - divergence (input) -! PU(NLEI1,2*KFIELD) - u wind (output) -! PV(NLEI1,2*KFIELD) - v wind (output) -! Organisation within NLEI1: -! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) -! overdimensioning -! 1 : n=NSMAX+2 -! 2 : n=NSMAX+1 -! 3 : n=NSMAX -! . : -! . : -! NSMAX+3 : n=0 -! NSMAX+4 : n=-1 - -! Implicit arguments : Eigenvalues of inverse Laplace operator -! -------------------- from YOMLAP - -! Method. -! ------- - -! Externals. None. -! ---------- - -! Reference. -! ---------- -! ECMWF Research Department documentation of the IFS -! Temperton, 1991, MWR 119 p1303 - -! Author. -! ------- -! Mats Hamrud and Philippe Courtier *ECMWF* - -! Modifications. -! -------------- -! Original : 00-02-01 From VDTUVAD in IFS CY22R1 - -! ------------------------------------------------------------------ - -IMPLICIT NONE - -INTEGER(KIND=JPIM), INTENT(IN) :: KM,KFIELD -REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) -REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:),PDIV(:,:) -REAL(KIND=JPRB), INTENT(IN) :: PU (:,:),PV (:,:) - -! LOCAL INTEGER SCALARS -INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, ISMAX,JI - -! LOCAL REAL SCALARS -REAL(KIND=JPRBT) :: ZKM -REAL(KIND=JPRBT) :: ZN(-1:R%NTMAX+4) -REAL(KIND=JPRBT) :: ZLAPIN(-1:R%NSMAX+4) -REAL(KIND=JPRBT) :: ZEPSNM(-1:R%NSMAX+4) - - - -! ------------------------------------------------------------------ - -!* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. -! ------------------------------------------ - -ZKM = KM -ISMAX = R%NSMAX -DO JN=KM-1,ISMAX+2 - IJ = ISMAX+3-JN - ZN(IJ) = F%RN(JN) - ZLAPIN(IJ) = F%RLAPIN(JN) - IF( JN >= 0 ) ZEPSNM(IJ) = PEPSNM(JN) -ENDDO -ZN(0) = F%RN(ISMAX+3) - -!* 1.1 U AND V (KM=0) . - -IF(KM == 0) THEN - DO J=1,KFIELD - IR = 2*J-1 - DO JI=2,ISMAX+3-KM - PDIV(JI-1,IR) = PDIV(JI-1,IR)+ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PV(JI,IR) - PVOR(JI-1,IR) = PVOR(JI-1,IR)-ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PU(JI,IR) - PDIV(JI+1,IR) = PDIV(JI+1,IR)-ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PV(JI,IR) - PVOR(JI+1,IR) = PVOR(JI+1,IR)+ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PU(JI,IR) - ENDDO - ENDDO -!* 1.2 U AND V (KM!=0) . - -ELSE - DO J=1,KFIELD - IR = 2*J-1 - II = IR+1 - DO JI=2,ISMAX+3-KM - PDIV(JI-1,II) = PDIV(JI-1,II)+ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PV(JI,II) - PDIV(JI-1,IR) = PDIV(JI-1,IR)+ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PV(JI,IR) - PVOR(JI-1,II) = PVOR(JI-1,II)-ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PU(JI,II) - PVOR(JI-1,IR) = PVOR(JI-1,IR)-ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PU(JI,IR) - PDIV(JI+1,II) = PDIV(JI+1,II)-ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PV(JI,II) - PDIV(JI+1,IR) = PDIV(JI+1,IR)-ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PV(JI,IR) - PVOR(JI+1,II) = PVOR(JI+1,II)+ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PU(JI,II) - PVOR(JI+1,IR) = PVOR(JI+1,IR)+ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PU(JI,IR) - PVOR(JI,IR) = PVOR(JI,IR)+ZKM*ZLAPIN(JI)*PV(JI,II) - PVOR(JI,II) = PVOR(JI,II)-ZKM*ZLAPIN(JI)*PV(JI,IR) - PDIV(JI,IR) = PDIV(JI,IR)+ZKM*ZLAPIN(JI)*PU(JI,II) - PDIV(JI,II) = PDIV(JI,II)-ZKM*ZLAPIN(JI)*PU(JI,IR) - ENDDO - ENDDO -ENDIF - -! ------------------------------------------------------------------ - -END SUBROUTINE VDTUVAD -END MODULE VDTUVAD_MOD