diff --git a/src/ZSOLVER/SURCOUCHE/mode_exchange2_ll.f90 b/src/ZSOLVER/SURCOUCHE/mode_exchange2_ll.f90 deleted file mode 100644 index d4942e8ce3a03d5e30b30bbf6a4488eaeb794cf9..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/SURCOUCHE/mode_exchange2_ll.f90 +++ /dev/null @@ -1,919 +0,0 @@ -!MNH_LIC Copyright 1998-2020 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -!Modifications: -! J. Escobar 15/09/2015: WENO5 & JPHEXT <> 1 -! P. Wautelet 21/05/2019: use name argument of LIST_ll for MPPDB_CHECK -!----------------------------------------------------------------- - -! ######################## - MODULE MODE_EXCHANGE2_ll -! ######################## -!! -!! Purpose -!! ------- -! -! The purpose of this module is the implementation of communication routine -! UPDATE_HALO2 that updates the second layer of the halo -!! -!! Glossary -!! -------- -! For short, we will refer as "halo2" the zone corresponding -! to the second layer of the halo to be updated. -!! -!! Routines Of The User Interface -!! ------------------------------ -! -! SUBROUTINES : UPDATE_HALO2_ll, INIT_HALO2_ll -! -!! Reference -!! --------- -! -! User Interface for Meso-NH parallel package -! Ph. Kloos, L. Giraud, R. Guivarch, D. Lugato -! -!! Authors -!! ------- -! -! R. Guivarch, D. Lugato * CERFACS * -! Ph. Kloos * CERFACS - CNRM * -! -!! Implicit Arguments -!! ------------------ -! -! Module MODD_ARGSLIST_ll -! types HALO2LIST_ll, LIST_ll -! -! Module MODD_STRUCTURE_ll -! types CRSPD_ll, ZONE_ll -! -! Module MODD_VAR_ll -! IP - Number of local processor=subdomain -! TCRRT_COMDATA - Current communication data structure for current model -! and local processor -! NHALO2_COM - MPI communicator for halo 2 -! NCOMBUFFSIZE2 - buffer size -! MNHREAL_MPI - mpi precision -! NNEXTTAG, NMAXTAG - variable to define message tag -! -!! Modifications -!! ------------- -! Original May 19, 1998 -! R. Guivarch June 24, 1998 _ll -! R. Guivarch June 29, 1998 MNHREAL_MPI -! N. Gicquel October 30, 1998 COPY_CRSPD2 -! J.Escobar 10/02/2012 : Bug , in MPI_RECV replace -! MPI_STATUSES_IGNORE with MPI_STATUS_IGNORE -! -!------------------------------------------------------------------------------- -! -implicit none -! - CONTAINS -! -!----------------------------------------------------------------------- -! -! ###################################################################### - SUBROUTINE INIT_HALO2_ll(TPHALO2LIST, KNBVAR, KDIMX, KDIMY, KDIMZ) -! ###################################################################### -! -!!**** *INIT_HALO2_ll* initialise the second layer of the halo -!! -!! -!! Purpose -!! ------- -! The purpose of this routine is to allocate and initialise the -! TPHALO2LIST variable which contains the second layer of the -! halo for each variable. -! -!! Implicit Arguments -!! ------------------ -! Module MODD_ARGSLIST_ll -! type HALO2LIST_ll -!! -!! Reference -!! --------- -! -!! Author -!! ------ -! P. Kloos * CERFACS - CNRM * -! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! - USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -! - IMPLICIT NONE -! -!* 0.1 Declarations of dummy arguments : -! - TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of HALO2_lls - INTEGER :: KNBVAR ! number of HALO2_lls to allocate - INTEGER :: KDIMX, KDIMY, KDIMZ ! dimensions of the HALO2_lls -! -! -!* 0.2 Declarations of local variables : -! - TYPE(HALO2LIST_ll), POINTER :: TZHALO2LIST - INTEGER :: JJ ! loop counter - - REAL , POINTER , CONTIGUOUS , DIMENSION(:,:) :: ZWEST,ZEAST,ZSOUTH,ZNORTH -! -!------------------------------------------------------------------------------- -! -!* 1. Allocate the list of HALO2_lls -! - ALLOCATE(TPHALO2LIST) - TZHALO2LIST => TPHALO2LIST -! - DO JJ=1, KNBVAR -! -!* 1.1 Allocate the current HALO2_ll -! - ALLOCATE(TZHALO2LIST%HALO2) - ALLOCATE(TZHALO2LIST%HALO2%WEST(KDIMY, KDIMZ)) - ALLOCATE(TZHALO2LIST%HALO2%EAST(KDIMY, KDIMZ)) - ALLOCATE(TZHALO2LIST%HALO2%SOUTH(KDIMX, KDIMZ)) - ALLOCATE(TZHALO2LIST%HALO2%NORTH(KDIMX, KDIMZ)) - ZWEST => TZHALO2LIST%HALO2%WEST - ZEAST => TZHALO2LIST%HALO2%EAST - ZSOUTH => TZHALO2LIST%HALO2%SOUTH - ZNORTH => TZHALO2LIST%HALO2%NORTH - !$acc enter data create(ZWEST,ZEAST,ZSOUTH,ZNORTH) - - !$acc kernels - ZWEST=0. - ZEAST=0. - ZSOUTH=0. - ZNORTH=0. - !$acc end kernels - - ALLOCATE(TZHALO2LIST%NEXT) -! -!* 1.2 Go to the next HALO2_ll, or terminate the list -! - IF (JJ < KNBVAR) THEN - TZHALO2LIST => TZHALO2LIST%NEXT - ELSE - DEALLOCATE(TZHALO2LIST%NEXT) - NULLIFY(TZHALO2LIST%NEXT) - ENDIF - ENDDO -! -!------------------------------------------------------------------------------- -! - END SUBROUTINE INIT_HALO2_ll -! -! ###################################################### - SUBROUTINE UPDATE_HALO2_ll(TPLIST, TPLISTHALO2, KINFO) -! ###################################################### -! -!!**** *UPDATE_HALO2_ll* - routine to update the second layer halo -!! -!! Purpose -!! ------- -! This routine updates the halo with the values computed by the -! neighbor subdomains. The fields to be updated are in the -! TPLIST list of fields. Before UPDATE_HALO is called, TPLIST -! has been filled with the fields to be communicated -! -!!** Method -!! ------ -! First the processors send their internal halos to their -! neighboring processors/subdomains, and then they receive -! their external halos from their neighboring processors. -! -!! Implicit Arguments -!! ------------------ -! Module MODD_ARGSLIST_ll -! type HALO2LIST_ll, LIST_ll -! -! Module MODD_VAR_ll -! TCRRT_COMDATA - Current communication data structure for current model -! and local processor -! NHALO2_COM - MPI communicator for halo 2 -! -!! Reference -!! --------- -! -!! Author -!! ------ -! P. Kloos * CERFACS - CNRM * -!! J.Escobar 21/03/014: add mppd_check for all updated field -! P. Wautelet 21/05/2019: use name argument of LIST_ll for MPPDB_CHECK -! -!-------------------------------------------------------------------------------! -!* 0. DECLARATIONS -! - USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll - USE MODD_VAR_ll, ONLY : TCRRT_COMDATA, NHALO2_COM -! - USE MODE_MPPDB -! -!* 0.1 declarations of arguments -! - TYPE(LIST_ll), POINTER :: TPLIST ! pointer to the list of - ! fields to be sent - TYPE(HALO2LIST_ll), POINTER :: TPLISTHALO2 ! pointer to the list of - ! halo2 to be received - INTEGER :: KINFO ! return status -! - TYPE(LIST_ll), POINTER :: TZFIELD -! - INTEGER :: ICOUNT - CHARACTER(len=2) :: YCOUNT -! -!------------------------------------------------------------------------------- -! -!* 1. SEND / RECV THE INTERNAL HALO TO/FROM THE NEIGHBORING PROCESSORS -! ---------------------------------------------------- -! - CALL SEND_RECV_CRSPD2(TCRRT_COMDATA%TSEND_HALO2, TCRRT_COMDATA%TRECV_HALO2, & - TPLIST, TPLISTHALO2, NHALO2_COM, KINFO) - -!------------------------------------------------------------------------------ -! -!* 2. ZONES TO SEND TO THE PROC ITSELF -! -------------------------------- -! - CALL COPY_CRSPD2(TCRRT_COMDATA%TSEND_HALO2, TCRRT_COMDATA%TRECV_HALO2, & - TPLIST, TPLISTHALO2, KINFO) -! -!JUAN MPP_CHECK2D/3D -! - IF (MPPDB_INITIALIZED) THEN - TZFIELD => TPLIST - ICOUNT=0 - DO WHILE (ASSOCIATED(TZFIELD)) - ICOUNT=ICOUNT+1 - WRITE(YCOUNT,'(I2)') ICOUNT - if (tzfield%l1d) then - CALL MPPDB_CHECK(TZFIELD%ARRAY1D,"UPDATE_HALO2_ll::"//tzfield%cname) - else if (tzfield%l2d) then - CALL MPPDB_CHECK(TZFIELD%ARRAY2D,"UPDATE_HALO2_ll::"//tzfield%cname) - else if (tzfield%l3d) then - CALL MPPDB_CHECK(TZFIELD%ARRAY3D,"UPDATE_HALO2_ll::"//tzfield%cname) - end if - TZFIELD => TZFIELD%NEXT - END DO - END IF -! -!---------------------------------------------------------------------- -! - END SUBROUTINE UPDATE_HALO2_ll -! -! ########################################################################## - SUBROUTINE COPY_CRSPD2(TPSENDCRSPD, TPRECVCRSPD, TPSENDLIST, TPRECVLIST, & - KINFO) -! ########################################################################## -! -!!**** *COPY_CRSPD2* - routine to copy zones that a proc sends to itself -!! -!! Purpose -!! ------- -!! -! Copy the field sendtplist of the zone sendcrspd to the field recvtplist -! of the zones recvcrspd. -! -!!** Method -!! ------ -! -!! Implicit Arguments -!! ------------------ -! Module MODD_STRUCTURE_ll -! type CRSPD_ll -! -! Module MODD_ARGSLIST_ll -! type HALO2LIST_ll, LIST_ll -! -! Module MODD_VAR_ll -! IP - Number of local processor=subdomain -! -!! Reference -!! --------- -! -!! Author -!! ------ -! N. Gicquel * CERFACS - CNRM * -! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! - USE MODD_STRUCTURE_ll, ONLY : CRSPD_ll - USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll - USE MODD_VAR_ll, ONLY : IP -! - IMPLICIT NONE -! -!* 0.1 declarations of arguments -! - TYPE(CRSPD_ll), POINTER :: TPSENDCRSPD, TPRECVCRSPD - TYPE(LIST_ll), POINTER :: TPSENDLIST - TYPE(HALO2LIST_ll), POINTER :: TPRECVLIST - INTEGER :: KINFO -! -!* 0.2 declarations of local variables -! - TYPE(CRSPD_ll), POINTER :: TZSEND, TZRECV -! -!------------------------------------------------------------------------------ -! - TZSEND => TPSENDCRSPD - DO WHILE (ASSOCIATED(TZSEND)) - IF (TZSEND%TELT%NUMBER == IP) THEN - TZRECV => TPRECVCRSPD - DO WHILE (ASSOCIATED(TZRECV)) - IF (TZRECV%TELT%NUMBER == IP& - & .AND.TZSEND%TELT%MSSGTAG == TZRECV%TELT%MSSGTAG) THEN - CALL COPY_ZONE2(TZSEND%TELT, TZRECV%TELT, TPSENDLIST, & - TPRECVLIST, KINFO) - ENDIF - TZRECV => TZRECV%TNEXT - ENDDO - ENDIF - TZSEND => TZSEND%TNEXT - ENDDO -! -!------------------------------------------------------------------------------ -! - END SUBROUTINE COPY_CRSPD2 -! -! #################################################################### - SUBROUTINE COPY_ZONE2(TPSEND, TPRECV, TPSENDLIST, TPRECVLIST, KINFO) -! #################################################################### -! -!!**** *COPY_ZONE2* - -!! -!! Purpose -!! ------- -! This routine copies the values of the fields in the TPSENDLIST to the -! halo 2 fields of TPRECVLIST according the TPSEND and TPRECV zones -! -!!** Method -!! ------ -! -!! Implicit Arguments -!! ------------------ -! Module MODD_STRUCTURE_ll -! type ZONE_ll -! -! Module MODD_ARGSLIST_ll -! type HALO2LIST_ll, LIST_ll -! -!! Reference -!! --------- -! -!! Author -!! ------ -! P. Kloos * CERFACS - CNRM * -! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! - USE MODD_STRUCTURE_ll, ONLY : ZONE_ll - USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll -! - IMPLICIT NONE -! -!* 0.1 declarations of arguments -! - TYPE(ZONE_ll) :: TPSEND, TPRECV - TYPE(LIST_ll), POINTER :: TPSENDLIST - TYPE(HALO2LIST_ll), POINTER :: TPRECVLIST - INTEGER :: KINFO -! -!* 0.2 declarations of local variables -! - TYPE(LIST_ll), POINTER :: TZLIST - TYPE(HALO2LIST_ll), POINTER :: TZHALO - REAL, DIMENSION(:,:), POINTER :: TZTAB2D - INTEGER :: IIBS, IIES, IJBS, IJES, IIBR, IIER, IJBR, IJER, IKES, IKBS, & - IKBR, IKER -! - INTEGER, PARAMETER :: ISENDNORTH=2, & - ISENDWEST=4, & - ISENDSOUTH=6, & - ISENDEAST=8, & - ISENDCYCNORTH=12, & - ISENDCYCWEST=14, & - ISENDCYCSOUTH=16, & - ISENDCYCEAST=18 -! -!------------------------------------------------------------------------------- -! - IIBS = TPSEND%NXOR - IIES = TPSEND%NXEND - IJBS = TPSEND%NYOR - IJES = TPSEND%NYEND - IKBS = TPSEND%NZOR - IKES = TPSEND%NZEND -! - IIBR = TPRECV%NXOR - IIER = TPRECV%NXEND - IJBR = TPRECV%NYOR - IJER = TPRECV%NYEND - IKBR = TPRECV%NZOR - IKER = TPRECV%NZEND -! - TZLIST => TPSENDLIST - TZHALO => TPRECVLIST - DO WHILE (ASSOCIATED(TZLIST)) - SELECT CASE(TPSEND%MSSGTAG) - CASE(ISENDNORTH, ISENDCYCNORTH) - TZTAB2D => TZHALO%HALO2%SOUTH - TZTAB2D(IIBR:IIER, IKBR:IKER) = & - TZLIST%ARRAY3D(IIBS:IIES, IJBS, IKBS:IKES) - CASE(ISENDSOUTH, ISENDCYCSOUTH) - TZTAB2D => TZHALO%HALO2%NORTH - TZTAB2D(IIBR:IIER, IKBR:IKER) = & - TZLIST%ARRAY3D(IIBS:IIES, IJBS, IKBS:IKES) - CASE(ISENDWEST, ISENDCYCWEST) - TZTAB2D => TZHALO%HALO2%EAST - TZTAB2D(IJBR:IJER, IKBR:IKER) = & - TZLIST%ARRAY3D(IIBS, IJBS:IJES, IKBS:IKES) - CASE(ISENDEAST, ISENDCYCEAST) - TZTAB2D => TZHALO%HALO2%WEST - TZTAB2D(IJBR:IJER, IKBR:IKER) = & - TZLIST%ARRAY3D(IIBS, IJBS:IJES, IKBS:IKES) - END SELECT - TZLIST => TZLIST%NEXT - TZHALO => TZHALO%NEXT - ENDDO -! -!------------------------------------------------------------------------------- -! - END SUBROUTINE COPY_ZONE2 -! -! ###################################################### - SUBROUTINE FILLOUT_ZONE2(TPHALO2LIST, TPZONE, PBUFFER) -! ###################################################### -! -!!**** *FILLOUT_ZONE2* - -!! -!! Purpose -!! ------- -! This routine receives the data of the fields of the TPHALO2LIST -! list of fields situated in the TPZONE ZONE_ll. -! -!!** Method -!! ------ -! First the data are received in a buffer. Then each field -! of the TPHALO2LIST list of fields is filled in at the -! location pointed by the zone. -! -!! Implicit Arguments -!! ------------------ -! Module MODD_STRUCTURE_ll -! type ZONE_ll -! -! Module MODD_ARGSLIST_ll -! type HALO2LIST_ll -! -!! Reference -!! --------- -! -!! Author -!! ------ -! P. Kloos * CERFACS - CNRM * -! -!------------------------------------------------------------------------------- -! -! -!* 0. DECLARATIONS -! ------------ -! - USE MODD_STRUCTURE_ll, ONLY : ZONE_ll - USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll - USE MODD_MPIF -! - IMPLICIT NONE -! -!* 0.1 declarations of arguments -! - TYPE(ZONE_ll) :: TPZONE ! ZONE_ll to be received - TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of halo2 to be received - REAL, DIMENSION(:) :: PBUFFER ! reception buffer for unpacking data -! -! INTEGER, DIMENSION(MPI_STATUS_SIZE) :: KSTATUS ! status of received message -! -!* 0.2 declarations of local variables -! - INTEGER :: JI,JJ,JK,JINC ! loop counters - TYPE(HALO2LIST_ll), POINTER :: TZHALO2 ! temporary list of halo2 -! - INTEGER, PARAMETER :: ISENDNORTH=2, & - ISENDWEST=4, & - ISENDSOUTH=6, & - ISENDEAST=8, & - ISENDCYCNORTH=12, & - ISENDCYCWEST=14, & - ISENDCYCSOUTH=16, & - ISENDCYCEAST=18 -! -!------------------------------------------------------------------------------- -! -!* 1. Set MPI message tags -! -------------------- -! ISENDNORTH = 2 -! ISENDWEST = 4 -! ISENDSOUTH = 6 -! ISENDEAST = 8 -! -! ISENDCYCNORTH = 12 ! ! ISENDCYCWEST = 14 ! | In case of cyclic - -! ISENDCYCSOUTH = 16 ! | boundary conditions -! ISENDCYCEAST = 18 ! / - -! -!* 2. Store the received message -! -------------------------- -! -!* 2.1 See at which side of the halo the message has to be stored -! - SELECT CASE(TPZONE%MSSGTAG) -! -!* 2.1.1 Message is to be put in the south halo -! - CASE(ISENDNORTH, ISENDCYCNORTH) -! -!* 2.1.1.1 Go over the TPHALO2LIST list of halo2 -! - TZHALO2 => TPHALO2LIST - JINC=0 - DO WHILE (ASSOCIATED(TZHALO2)) -! -!* 2.1.1.2 Fill out the buffer in the south part of the halo2 -! - DO JK=TPZONE%NZOR, TPZONE%NZEND - DO JI=TPZONE%NXOR, TPZONE%NXEND -! - JINC = JINC + 1 - TZHALO2%HALO2%SOUTH(JI,JK) = PBUFFER(JINC) -! - ENDDO - ENDDO -! -!* 2.1.1.3 Go to the next halo2 in the list -! - TZHALO2 => TZHALO2%NEXT -! - ENDDO -! -!* 2.1.2 Message is coming from the east -! - CASE(ISENDWEST, ISENDCYCWEST) -! -!* 2.1.2.1 Go over the TPHALO2LIST list of halo2 -! - TZHALO2 => TPHALO2LIST - JINC=0 - DO WHILE (ASSOCIATED(TZHALO2)) -! -!* 2.1.2.2 Fill out the buffer in the east part of the halo2 -! - DO JK=TPZONE%NZOR, TPZONE%NZEND - DO JJ=TPZONE%NYOR, TPZONE%NYEND -! - JINC = JINC + 1 - TZHALO2%HALO2%EAST(JJ,JK) = PBUFFER(JINC) -! - ENDDO - ENDDO -! -!* 2.1.2.3 Go to the next halo2 in the list -! - TZHALO2 => TZHALO2%NEXT -! - ENDDO -! -!* 2.1.3 Message is coming from the north -! - CASE(ISENDSOUTH, ISENDCYCSOUTH) -! -!* 2.1.3.1 Go over the TPHALO2LIST list of halo2 -! - TZHALO2 => TPHALO2LIST - JINC=0 - DO WHILE (ASSOCIATED(TZHALO2)) -! -!* 2.1.3.2 Fill out the buffer in the north part of the halo2 -! - DO JK=TPZONE%NZOR, TPZONE%NZEND - DO JI=TPZONE%NXOR, TPZONE%NXEND -! - JINC = JINC + 1 - TZHALO2%HALO2%NORTH(JI,JK) = PBUFFER(JINC) -! - ENDDO - ENDDO -! -!* 2.1.3.3 Go to the next halo2 in the list -! - TZHALO2 => TZHALO2%NEXT -! - ENDDO -! -!* 2.1.4 Message is coming from the west -! - CASE(ISENDEAST, ISENDCYCEAST) -! -!* 2.1.4.1 Go over the TPHALO2LIST list of halo2 -! - TZHALO2 => TPHALO2LIST - JINC=0 - DO WHILE (ASSOCIATED(TZHALO2)) -! -!* 2.1.4.2 Fill out the buffer in the west part of the halo2 -! - DO JK=TPZONE%NZOR, TPZONE%NZEND - DO JJ=TPZONE%NYOR, TPZONE%NYEND -! - JINC = JINC + 1 - TZHALO2%HALO2%WEST(JJ,JK) = PBUFFER(JINC) -! - ENDDO - ENDDO -! -!* 2.1.4.3 Go to the next halo2 in the list -! - TZHALO2 => TZHALO2%NEXT -! - ENDDO -! - END SELECT -! -!------------------------------------------------------------------------------- -! - END SUBROUTINE FILLOUT_ZONE2 -! -! ######################################################################## - SUBROUTINE SEND_RECV_CRSPD2(TPCRSPDSEND, TPCRSPDRECV, TPFIELDLISTSEND, & - TPFIELDLISTRECV, KMPI_COMM, KINFO) -! ######################################################################## -! -!!**** *SEND_RECV_CRSPD2* - -! -!! Purpose -!! ------- -! This routine sends the data of the TPFIELDLISTSEND list -! to the correspondants of the TPCRSPDSEND list -! and receives the data of the TPFIELDLISTRECV list -! from the correspondants of the TPCRSPDRECV list -! -!!** Method -!! ------ -! -! This routine is based on the following rule : -! one sent for one received (if it is possible); -! The algorithm is the following : -! -! while (there is some messages to send) -! OR (there is some messages to receive) -! do -! if (there is some messages to send) -! send the first of the list -! end if -! if (there is some messages to receive) -! try to receive -! end if -! done -! -! The receptions are non-blocking and don't follow necessarly -! the order of the TPCRSPDRECV list -! -!! Implicit Arguments -!! ------------------ -! Module MODD_STRUCTURE_ll -! type CRSPD_ll, ZONE_ll -! -! Module MODD_ARGSLIST_ll -! type LIST_ll, HALO2LIST_ll -! -! Module MODD_VAR_ll -! IP - Number of local processor=subdomain -! NCOMBUFFSIZE2 - buffer size -! NNEXTTAG, NMAXTAG - variable to define message tag -! -!! Reference -!! --------- -! -!! Author -!! ------ -! P. Kloos * CERFACS - CNRM * -! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! - USE MODD_STRUCTURE_ll, ONLY : CRSPD_ll, ZONE_ll - USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll - use modd_precision, only: MNHREAL_MPI - USE MODD_VAR_ll, ONLY : NCOMBUFFSIZE2, IP, NNEXTTAG, NMAXTAG - USE MODE_EXCHANGE_ll, ONLY : FILLIN_BUFFERS - USE MODD_MPIF -!JUANZ - USE MODD_CONFZ, ONLY : LMNH_MPI_BSEND -!JUANZ -! - USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE -! - IMPLICIT NONE -! -!* 0.1 declarations of arguments -! - TYPE(CRSPD_ll), POINTER :: TPCRSPDSEND, TPCRSPDRECV - TYPE(LIST_ll), POINTER :: TPFIELDLISTSEND - TYPE(HALO2LIST_ll), POINTER :: TPFIELDLISTRECV - INTEGER :: KMPI_COMM - INTEGER :: KINFO -! -!* 0.2 declarations of local variables -! - INTEGER :: JINC, JI, JJ, JK ! Loop and counter variables - INTEGER :: FOUND, KERROR -! -!JUAN -!if defined (MNH_MPI_ISEND) - REAL, DIMENSION (:,:), ALLOCATABLE,TARGET :: TZBUFFER ! Buffers for info - ! received -!!$#else -!!$ REAL, DIMENSION (NCOMBUFFSIZE2), TARGET :: TZBUFFER ! Buffers for info -!!$ ! received -!!$#endif -!JUAN -! - ! INTEGER IRECVSTATUS(MPI_STATUS_SIZE) ! Status of completed receive request - LOGICAL :: IRECVFLAG, ISENDFLAG - INTEGER :: IMSGTAG, ISENDERPROC -! - INTEGER :: IRECVNB, ISENDNB ! Total numbers of receive and send to do - INTEGER :: IRECVDONE ! RECEIVE COMPLETED (receive and treated) -! - TYPE(CRSPD_ll), POINTER :: TPMAILSEND, TPMAILRECV - TYPE(ZONE_ll), POINTER :: TZZONESEND -! - TYPE(LIST_ll), POINTER :: TZFIELDLISTSEND - TYPE(HALO2LIST_ll), POINTER :: TZFIELDLISTRECV - INTEGER, SAVE :: ITAGOFFSET = 0 -! JUAN -!if defined (MNH_MPI_ISEND) -INTEGER,PARAMETER :: MPI_MAX_REQ = 1024 -!INTEGER,SAVE,DIMENSION(MPI_MAX_REQ) :: REQ_TAB -!INTEGER,SAVE,DIMENSION(MPI_STATUS_SIZE,MPI_MAX_REQ) :: STATUS_TAB -INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB -INTEGER :: NB_REQ,NFIRST_REQ_RECV -!endif -! JUAN -! -!------------------------------------------------------------------------------- -! -!* 1. INITIALISATIONS -! --------------- -! - TZFIELDLISTSEND => TPFIELDLISTSEND - TZFIELDLISTRECV => TPFIELDLISTRECV -! - IRECVDONE = 0 -! - IF (ASSOCIATED(TPCRSPDRECV)) THEN - IRECVNB = TPCRSPDRECV%NCARDDIF - ELSE - IRECVNB = 0 - ENDIF - IF (ASSOCIATED(TPCRSPDSEND)) THEN - ISENDNB = TPCRSPDSEND%NCARDDIF - ELSE - ISENDNB = 0 - ENDIF - -!JUAN -!if defined (MNH_MPI_ISEND) - IF (LMNH_MPI_BSEND) THEN - ALLOCATE(TZBUFFER(NCOMBUFFSIZE2,1)) - ELSE - ALLOCATE(TZBUFFER(NCOMBUFFSIZE2,ISENDNB+IRECVNB)) - NB_REQ = 0 - ALLOCATE(REQ_TAB(ISENDNB+IRECVNB)) - END IF -!endif -!JUAN -! - TPMAILRECV => TPCRSPDRECV - TPMAILSEND => TPCRSPDSEND -! -!NZJUAN CALL MPI_BARRIER(KMPI_COMM, KERROR) -! -!------------------------------------------------------------------------------- -! -!* 2. MAIN LOOP -! --------- -! - DO WHILE (ASSOCIATED(TPMAILSEND)) -! -!* 2.1 if there is still something to send -! - IF (ASSOCIATED(TPMAILSEND)) THEN - TZZONESEND => TPMAILSEND%TELT - IF (TZZONESEND%NUMBER /= IP) THEN - JINC = 0 -!JUAN -!if defined(MNH_MPI_ISEND) - IF ( .NOT. LMNH_MPI_BSEND) THEN - NB_REQ = NB_REQ + 1 - CALL FILLIN_BUFFERS(TZFIELDLISTSEND, TZZONESEND, TZBUFFER(:,NB_REQ), JINC) - else - CALL FILLIN_BUFFERS(TZFIELDLISTSEND, TZZONESEND, TZBUFFER(:,1), JINC) - endif -!JUAN -!if defined(MNH_MPI_BSEND) - IF (LMNH_MPI_BSEND) THEN - CALL MPI_BSEND(TZBUFFER, JINC, MNHREAL_MPI, & - TZZONESEND%NUMBER - 1, TZZONESEND%MSSGTAG + ITAGOFFSET, & - KMPI_COMM, KERROR) -else -!JUAN -!if defined(MNH_MPI_ISEND) - CALL MPI_ISEND(TZBUFFER(1,NB_REQ), JINC, MNHREAL_MPI, & - TZZONESEND%NUMBER - 1, TZZONESEND%MSSGTAG + ITAGOFFSET, & - KMPI_COMM, REQ_TAB(NB_REQ), KERROR) - - endif -!JUAN - - ENDIF - TPMAILSEND => TPMAILSEND%TNEXT - ENDIF - ENDDO - -!NZJUAN CALL MPI_BARRIER(KMPI_COMM, KERROR) - -! JUAN -!if defined (MNH_MPI_ISEND) - IF ( .NOT. LMNH_MPI_BSEND) THEN - NFIRST_REQ_RECV = NB_REQ - endif - ! JUAN - - DO WHILE (ASSOCIATED(TPMAILRECV)) - IF (TPMAILRECV%TELT%NUMBER == IP) THEN - TPMAILRECV => TPMAILRECV%TNEXT - ELSE -! JUAN -!if defined (MNH_MPI_ISEND) - IF ( .NOT. LMNH_MPI_BSEND) THEN - NB_REQ = NB_REQ + 1 - CALL MPI_IRECV(TZBUFFER(1,NB_REQ), NCOMBUFFSIZE2, MNHREAL_MPI, & - TPMAILRECV%TELT%NUMBER-1, & - TPMAILRECV%TELT%MSSGTAG + ITAGOFFSET, & - KMPI_COMM, REQ_TAB(NB_REQ), KERROR) -else - CALL MPI_RECV(TZBUFFER, NCOMBUFFSIZE2, MNHREAL_MPI, & - TPMAILRECV%TELT%NUMBER-1, & - TPMAILRECV%TELT%MSSGTAG + ITAGOFFSET, & - KMPI_COMM, MPI_STATUS_IGNORE, KERROR) - CALL FILLOUT_ZONE2(TZFIELDLISTRECV, TPMAILRECV%TELT, TZBUFFER(:,1)) -endif -! JUAN - TPMAILRECV => TPMAILRECV%TNEXT - ENDIF - - ENDDO - -! JUAN -!if defined (MNH_MPI_ISEND) - IF ( .NOT. LMNH_MPI_BSEND) THEN - CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,KINFO) - - TPMAILRECV => TPCRSPDRECV - NB_REQ = NFIRST_REQ_RECV - - DO WHILE (ASSOCIATED(TPMAILRECV)) - IF (TPMAILRECV%TELT%NUMBER == IP) THEN - TPMAILRECV => TPMAILRECV%TNEXT - ELSE - NB_REQ = NB_REQ + 1 - CALL FILLOUT_ZONE2(TZFIELDLISTRECV, TPMAILRECV%TELT, TZBUFFER(:,NB_REQ)) - TPMAILRECV => TPMAILRECV%TNEXT - ENDIF - - ENDDO - - DEALLOCATE(REQ_TAB) - endif -!JUAN -! - DEALLOCATE(TZBUFFER) - ITAGOFFSET = MOD((ITAGOFFSET + NNEXTTAG), NMAXTAG) -! -!NZJUAN CALL MPI_BARRIER(KMPI_COMM, KERROR) -! -!-------------------------------------------------------------------------------! - END SUBROUTINE SEND_RECV_CRSPD2 -! -END MODULE MODE_EXCHANGE2_ll diff --git a/src/ZSOLVER/advec_4th_order_aux.f90 b/src/ZSOLVER/advec_4th_order_aux.f90 deleted file mode 100644 index 9838c4762cf61ca7e0ba265ebd579076e5cc3352..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/advec_4th_order_aux.f90 +++ /dev/null @@ -1,728 +0,0 @@ -!MNH_LIC Copyright 2005-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! ############################### - MODULE MODI_ADVEC_4TH_ORDER_AUX -! ############################### -! -INTERFACE -! - SUBROUTINE ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PFIELDT, KGRID, & - PMEANX, PMEANY,TPHALO2 ) -! -USE MODD_ARGSLIST_ll, ONLY : HALO2_ll -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -! -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PMEANX, PMEANY ! fluxes -REAL, DIMENSION(:,:,:), INTENT(IN) :: PFIELDT ! variable at t -INTEGER, INTENT(IN) :: KGRID ! C grid localisation -! -TYPE(HALO2_ll), POINTER :: TPHALO2 ! halo2 for the field at t -! -END SUBROUTINE ADVEC_4TH_ORDER_ALGO -! -!------------------------------------------------------------------------------- -! -#ifndef MNH_OPENACC - FUNCTION MZF4(PA) RESULT(PMZF4) -#else - SUBROUTINE MZF4(PA,PMZF4) -#endif -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux - ! side -REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZF4 ! result at mass - ! localization -! -#ifndef MNH_OPENACC - END FUNCTION MZF4 -#else - END SUBROUTINE MZF4 -#endif -! -!------------------------------------------------------------------------------- -! -#ifndef MNH_OPENACC - FUNCTION MZM4(PA) RESULT(PMZM4) -#else - SUBROUTINE MZM4(PA,PMZM4) -#endif -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass - ! localization -REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZM4 ! result at flux - ! localization -#ifndef MNH_OPENACC - END FUNCTION MZM4 -#else - END SUBROUTINE MZM4 -#endif -! -!------------------------------------------------------------------------------- -! -END INTERFACE -! -END MODULE MODI_ADVEC_4TH_ORDER_AUX -! -!------------------------------------------------------------------------------- -! -! ######################################################################## - SUBROUTINE ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PFIELDT, KGRID, & - PMEANX, PMEANY,TPHALO2 ) -! ######################################################################## -!! -!!**** *ADVEC_4TH_ORDER_ALGO * - routine used to compute 4th order horizontal -!! advection fluxes of 3D prognostic variables -!! -!! PURPOSE -!! ------- -!! The purpose of this routine is to compute 2sd or 4th order horizontal -!! advection fluxes of a prognostic variable. -!! -!!** METHOD -!! ------ -!! In case of cyclic LBCs, the routine returns the scalar component of the -!! advection fluxes by applying a 4th order horizontal averaging operator to -!! the prognostic variable on each grid level. In the case of open LBCs, the -!! averaging operator degenerates to a 2nd order one on the first ring -!! inside the computationnal domain. -!! The "halo2" (or the second layer of the halo) of the prognostic -!! variable is passed as argument. -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! -!! MODULE MODD_ARGSLIST -!! HALO2LIST_ll : type for a list of "HALO2_lls" -!! -!! REFERENCE -!! --------- -!! Book2 of documentation ( routine ADVEC_4TH_ORDER ) -!! User Interface for the MesoNH Parallel Package -!! -!! AUTHOR -!! ------ -!! J.-P. Pinty * Laboratoire d'Aerologie* -!! -!! MODIFICATIONS -!! ------------- -!! Original 25/10/05 -! J. Escobar 21/03/2013: for HALOK comment all NHALO=1 test -! P. Wautelet 21/11/2019: TPHALO2 dummy argument is no longer optional -! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_ARGSLIST_ll, ONLY: HALO2_ll -USE MODD_CONF -! -#ifdef MNH_OPENACC -USE MODE_DEVICE -#endif -use mode_ll, only: GET_INDICE_ll, LWEST_ll, LEAST_ll, LNORTH_ll, LSOUTH_ll -#ifdef MNH_OPENACC -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -#endif -use mode_mppdb -#ifdef MNH_OPENACC -use mode_msg -#endif -! -IMPLICIT NONE -! -!* 0.1 Declarations of dummy arguments : -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -! -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PMEANX, PMEANY ! fluxes -REAL, DIMENSION(:,:,:), INTENT(IN) :: PFIELDT ! variable at t -INTEGER, INTENT(IN) :: KGRID ! C grid localisation -! -TYPE(HALO2_ll), POINTER :: TPHALO2 ! halo2 for the field at t -! -!* 0.2 Declarations of local variables : -! -INTEGER:: IW,IE,IS,IN,IT,IB,IWF,IEF,ISF,INF ! Coordinate of forth order diffusion area -! -INTEGER:: IIB,IJB ! Begining useful area in x,y directions -INTEGER:: IIE,IJE ! End useful area in x,y directions -! -INTEGER:: ILUOUT,IRESP ! for prints -! -! JUAN ACC -LOGICAL :: GWEST , GEAST -LOGICAL :: GSOUTH , GNORTH -REAL, DIMENSION(:,:), pointer, contiguous :: ZHALO2_WEST, ZHALO2_EAST -REAL, DIMENSION(:,:), pointer, contiguous :: ZHALO2_SOUTH, ZHALO2_NORTH -! - -!$acc data present( PMEANX, PMEANY, PFIELDT ) - -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PFIELDT,"ADVEC_4TH_ORDER_ALGO beg:PFIELDT") -END IF - -!------------------------------------------------------------------------------- -! -!* 0.3. COMPUTES THE DOMAIN DIMENSIONS -! ------------------------------ -! -! -CALL GET_INDICE_ll(IIB,IJB,IIE,IJE) -! -GWEST = LWEST_ll() -GEAST = LEAST_ll() -GSOUTH = LSOUTH_ll() -GNORTH = LNORTH_ll() -! -!------------------------------------------------------------------------------- -! -!* 0.4. INITIALIZE THE FIELDS -! --------------------- -! -!$acc kernels present(PMEANX,PMEANY) -PMEANX(:,:,:) = 0.0 -PMEANY(:,:,:) = 0.0 -!$acc end kernels -! -!------------------------------------------------------------------------------- -! -! -!* 1. CALCULATE THE NUMERICAL MEAN IN THE X DIRECTION -! ----------------------------------------------- -! -SELECT CASE ( HLBCX(1) ) ! X direction LBC type: (1) for left side -! -!* 1.1 CYCLIC CASE IN THE X DIRECTION: -! -CASE ('CYCL') ! In that case one must have HLBCX(1) == HLBCX(2) -! -#ifdef MNH_OPENACC -call Print_msg( NVERB_WARNING, 'GEN', 'ADVEC_4TH_ORDER_ALGO', 'OpenACC: HLBCX(1) AND CYCL not yet tested' ) -#endif -ZHALO2_WEST => TPHALO2%WEST -ZHALO2_EAST => TPHALO2%EAST -! -!$acc kernels present(PMEANX,ZHALO2_WEST,ZHALO2_EAST) - IW=IIB+1 - IE=IIE -! - IF(KGRID == 2) THEN - IWF=IW-1 - IEF=IE-1 - ELSE - IWF=IW - IEF=IE - END IF -! -!* lateral boundary conditions - PMEANX(IWF-1,:,:) = (7.0*( PFIELDT(IW-1,:,:)+PFIELDT(IW-2,:,:) ) - & - ( PFIELDT(IW,:,:)+ZHALO2_WEST(:,:) ) )/12.0 -! - PMEANX(IEF+1,:,:) = (7.0*( PFIELDT(IE+1,:,:)+PFIELDT(IE,:,:) ) - & - ( ZHALO2_EAST(:,:)+PFIELDT(IE-1,:,:) ) )/12.0 -! -!* inner domain - PMEANX(IWF:IEF,:,:) = (7.0*( PFIELDT(IW:IE,:,:)+PFIELDT(IW-1:IE-1,:,:) ) - & - ( PFIELDT(IW+1:IE+1,:,:)+PFIELDT(IW-2:IE-2,:,:) ) )/12.0 -!$acc end kernels -! -!!$! -!!$ -!!$ IF(NHALO == 1) THEN -!!$ PMEANX(IWF-1,:,:) = (7.0*( PFIELDT(IW-1,:,:)+PFIELDT(IW-2,:,:) ) - & -!!$ ( PFIELDT(IW,:,:)+ZPHALO2_WEST(:,:) ) )/12.0 -!!$! -!!$ PMEANX(IEF+1,:,:) = (7.0*( PFIELDT(IE+1,:,:)+PFIELDT(IE,:,:) ) - & -!!$ ( ZPHALO2_EAST(:,:)+PFIELDT(IE-1,:,:) ) )/12.0 -!!$ ENDIF -!!$! -!!$ PMEANX(IWF:IEF,:,:) = (7.0*( PFIELDT(IW:IE,:,:)+PFIELDT(IW-1:IE-1,:,:) ) - & -!!$ ( PFIELDT(IW+1:IE+1,:,:)+PFIELDT(IW-2:IE-2,:,:) ) )/12.0 -!!$! -!* 1.2 NON CYCLIC CASE IN THE X DIRECTION -! -CASE ('OPEN','WALL','NEST') -! -ZHALO2_WEST => TPHALO2%WEST -ZHALO2_EAST => TPHALO2%EAST -! -!$acc kernels present(PMEANX,ZHALO2_WEST,ZHALO2_EAST) - IF (GWEST) THEN - IF(KGRID == 2) THEN - IW=IIB+2 ! special case of C grid - ELSE - IW=IIB+1 - END IF - ELSE -!!$ IF(NHALO == 1) THEN - IW=IIB+1 -!!$ ELSE -!!$ IW=IIB -!!$ ENDIF - ENDIF -!!$ IF (GEAST .OR. NHALO == 1) THEN - IF (GEAST) THEN -! T. Maric -! IE=IIE-1 ! original - IE=IIE - ELSE - IE=IIE - END IF -! - IF(KGRID == 2) THEN - IWF=IW-1 - IEF=IE-1 - ELSE - IWF=IW - IEF=IE - END IF -! -! T. Maric. 16.1.2006. -! write(*,*)' IW, IE, IWF, IEF = ',IW, IE, IWF, IEF -! stop 'Stopping in advec_4th_order_aux.f90' -! -!* Use a second order scheme at the physical border -! - IF (GWEST) THEN - PMEANX(IWF-1,:,:) = 0.5*( PFIELDT(IW-1,:,:)+PFIELDT(IW-2,:,:) ) - ! T. Maric - ! PMEANX(1,:,:) = PMEANX(IWF-1,:,:) - ! extrapolate - !PMEANX(1,:,:) = 0.5*(3.0*PFIELDT(1,:,:) - PFIELDT(2,:,:)) -!!$ ELSE IF (NHALO == 1) THEN - ELSE - PMEANX(IWF-1,:,:) = (7.0*( PFIELDT(IW-1,:,:)+PFIELDT(IW-2,:,:) ) - & - ( PFIELDT(IW,:,:)+ZHALO2_WEST(:,:) ) )/12.0 - ENDIF -! - IF (GEAST) THEN - PMEANX(IEF+1,:,:) = 0.5*( PFIELDT(IE+1,:,:)+PFIELDT(IE,:,:) ) -!!$ ELSEIF (NHALO == 1) THEN - ELSE - PMEANX(IEF+1,:,:) = (7.0*( PFIELDT(IE+1,:,:)+PFIELDT(IE,:,:) ) - & - ( ZHALO2_EAST(:,:)+PFIELDT(IE-1,:,:) ) )/12.0 - ENDIF -! -!* Use a fourth order scheme elsewhere -! - PMEANX(IWF:IEF,:,:) = (7.0*( PFIELDT(IW:IE,:,:)+PFIELDT(IW-1:IE-1,:,:) ) - & - ( PFIELDT(IW+1:IE+1,:,:)+PFIELDT(IW-2:IE-2,:,:) ) )/12.0 -!$acc end kernels -END SELECT -! -!------------------------------------------------------------------------------- -! -!* 2. COMPUTES THE 4TH ORDER MEAN IN THE Y DIRECTION -! ---------------------------------------------- -! -IF ( .NOT. L2D ) THEN - SELECT CASE ( HLBCY(1) ) ! Y direction LBC type: (1) for left side -! -!* 2.1 CYCLIC CASE IN THE Y DIRECTION: -! - CASE ('CYCL') ! In that case one must have HLBCY(1) == HLBCY(2) -! -#ifdef MNH_OPENACC -call Print_msg( NVERB_WARNING, 'GEN', 'ADVEC_4TH_ORDER_ALGO', 'OpenACC: HLBCX(2) AND CYCL not yet tested' ) -#endif -ZHALO2_SOUTH => TPHALO2%SOUTH -ZHALO2_NORTH => TPHALO2%NORTH -! -!$acc kernels present(PMEANY,ZHALO2_SOUTH,ZHALO2_NORTH) -! -! - IS=IJB+1 - IN=IJE -! - IF(KGRID == 3) THEN - ISF=IS-1 - INF=IN-1 - ELSE - ISF=IS - INF=IN - END IF -! -!* lateral boundary conditions - PMEANY(:,ISF-1,:) = (7.0*( PFIELDT(:,IS-1,:)+PFIELDT(:,IS-2,:) ) - & - ( PFIELDT(:,IS,:)+ZHALO2_SOUTH(:,:) ) )/12.0 -! - PMEANY(:,INF+1,:) = (7.0*( PFIELDT(:,IN+1,:)+PFIELDT(:,IN,:) ) - & - ( ZHALO2_NORTH(:,:)+PFIELDT(:,IN-1,:) ) )/12.0 -! -!* inner domain - PMEANY(:,ISF:INF,:) = (7.0*( PFIELDT(:,IS:IN,:)+PFIELDT(:,IS-1:IN-1,:)) - & - ( PFIELDT(:,IS+1:IN+1,:)+PFIELDT(:,IS-2:IN-2,:) ))/12.0 -!$acc end kernels -!!$! -!!$ IF(NHALO == 1) THEN -!!$ PMEANY(:,ISF-1,:) = (7.0*( PFIELDT(:,IS,:)+PFIELDT(:,IS-1,:) ) - & -!!$ ( PFIELDT(:,IS+1,:)+ZPHALO2_SOUTH(:,:) ) )/12.0 -!!$! -!!$ PMEANY(:,ISF+1,:) = (7.0*( PFIELDT(:,IS,:)+PFIELDT(:,IS-1,:) ) - & -!!$ ( ZPHALO2_NORTH(:,:)+PFIELDT(:,IS-2,:) ) )/12.0 -!!$ ENDIF -!!$! -!!$ PMEANY(:,ISF:INF,:) = (7.0*( PFIELDT(:,IS:IN,:)+PFIELDT(:,IS-1:IN-1,:)) - & -!!$ ( PFIELDT(:,IS+1:IN+1,:)+PFIELDT(:,IS-2:IN-2,:) ))/12.0 -!!$! -!* 2.2 NON CYCLIC CASE IN THE Y DIRECTION -! - CASE ('OPEN','WALL','NEST') -! -ZHALO2_SOUTH => TPHALO2%SOUTH -ZHALO2_NORTH => TPHALO2%NORTH -! -!$acc kernels present(PMEANY,ZHALO2_SOUTH,ZHALO2_NORTH) - IF (GSOUTH) THEN - IF(KGRID == 3) THEN - IS=IJB+2 ! special case of C grid - ELSE - IS=IJB+1 - END IF - ELSE -!!$ IF(NHALO == 1) THEN - IS=IJB+1 -!!$ ELSE -!!$ IS=IJB -!!$ ENDIF - ENDIF -!!$ IF (GNORTH .OR. NHALO == 1) THEN - IF (GNORTH) THEN -! T. Maric -! IN=IJE-1 ! original - IN=IJE - ELSE - IN=IJE - END IF -! - IF(KGRID == 3) THEN - ISF=IS-1 - INF=IN-1 - ELSE - ISF=IS - INF=IN - END IF -! -!* Use a second order scheme at the physical border -! - IF (GSOUTH) THEN - PMEANY(:,ISF-1,:) = 0.5*( PFIELDT(:,IS-1,:)+PFIELDT(:,IS-2,:) ) - ! T. Maric - ! PMEANY(:,1,:) = PMEANY(:,ISF-1,:) - ! extrapolate - !PMEANY(:,1,:) = 0.5*(3.0*PFIELDT(:,1,:) - PFIELDT(:,2,:)) -!!$ ELSEIF (NHALO == 1) THEN - ELSE -!!$ PMEANY(:,ISF-1,:) = (7.0*( PFIELDT(:,IS,:)+PFIELDT(:,IS-1,:)) - & -!!$ ( PFIELDT(:,IS+1,:)+TPHALO2%SOUTH(:,:) ))/12.0 - PMEANY(:,ISF-1,:) = (7.0*( PFIELDT(:,IS-1,:)+PFIELDT(:,IS-2,:)) - & - ( PFIELDT(:,IS,:)+ZHALO2_SOUTH(:,:) ))/12.0 - ENDIF -! - IF (GNORTH) THEN - PMEANY(:,INF+1,:) = 0.5*( PFIELDT(:,IN+1,:)+PFIELDT(:,IN,:) ) -!!$ ELSEIF (NHALO == 1) THEN - ELSE -!!$ PMEANY(:,INF+1,:) = (7.0*( PFIELDT(:,IN,:)+PFIELDT(:,IN-1,:)) - & -!!$ ( TPHALO2%NORTH(:,:)+PFIELDT(:,IN-2,:) ))/12.0 - PMEANY(:,INF+1,:) = (7.0*( PFIELDT(:,IN+1,:)+PFIELDT(:,IN,:)) - & - ( ZHALO2_NORTH(:,:)+PFIELDT(:,IN-1,:) ))/12.0 - ENDIF -! -!* Use a fourth order scheme elsewhere -! - PMEANY(:,ISF:INF,:) = (7.0*( PFIELDT(:,IS:IN,:)+PFIELDT(:,IS-1:IN-1,:)) - & - ( PFIELDT(:,IS+1:IN+1,:)+PFIELDT(:,IS-2:IN-2,:) ))/12.0 -!$acc end kernels -! - END SELECT -ELSE -!$acc kernels present(PMEANY) - PMEANY(:,:,:) = 0.0 -!$acc end kernels -ENDIF -! -IF (MPPDB_INITIALIZED) THEN - !Check all OUT arrays - CALL MPPDB_CHECK(PMEANX,"ADVEC_4TH_ORDER_ALGO end:PMEANX") - CALL MPPDB_CHECK(PMEANY,"ADVEC_4TH_ORDER_ALGO end:PMEANY") -END IF - -!$acc end data - -!------------------------------------------------------------------------------- -! -END SUBROUTINE ADVEC_4TH_ORDER_ALGO -! -!------------------------------------------------------------------------------- -! -! ################################ -#ifndef MNH_OPENACC - FUNCTION MZF4(PA) RESULT(PMZF4) -#else - SUBROUTINE MZF4(PA,PMZF4) -#endif -! ################################ -! -!!**** *MZF4* - 4th order Shuman operator : mean operator in z direction for a -!! variable at a flux side -!! -!! PURPOSE -!! ------- -!! The purpose of this function is to compute a 4th order mean value -!! along the z direction (K index) for a field PA localized at a z-flux -!! point (w point). The result is localized at a mass point. -! -!!** METHOD -!! ------ -!! The result PMZF4(:,:,k) is defined by -!! PMZF4(:,:,k)=0.5*(PA(:,:,k)+PA(:,:,k+1)) at k=1 and size(PA,3)-1 -!! PMZF4(:,:,k)=-999. at k=size(PA,3) -!! PMZF4(:,:,k)=7/12*(PA(:,:,k)+PA(:,:,k+1)) -!! -1/12*(PA(:,:,k-1)+PA(:,:,k+2)) elsewhere -!! -!! EXTERNAL -!! -------- -!! NONE -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! NONE -!! -!! REFERENCE -!! --------- -!! Book2 of documentation of Meso-NH (SHUMAN operators) -!! Technical specifications Report of The Meso-NH (chapters 3) -!! -!! AUTHOR -!! ------ -!! J.-P. Pinty * Lab Aerologie * -!! -!! MODIFICATIONS -!! ------------- -!! Original 25/10/05 -!! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -IMPLICIT NONE -! -!* 0.1 Declarations of argument and result -! -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux - ! side -REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZF4 ! result at mass - ! localization -! -!* 0.2 Declarations of local variables -! -! -INTEGER :: JK ! loop index in z direction -INTEGER :: IKU ! upper bound in z direction of PA -! -INTEGER :: IIU,IJU,IIJU ! upper bounds in the x and y directions of PA -INTEGER :: JIJ,JIJK ! running loop indexes after linearisation -INTEGER :: JIJKOR1,JIJKEND1 ! loop boundaries -INTEGER :: JIJKOR2,JIJKEND2 ! loop boundaries -INTEGER :: JIJKOR3,JIJKEND3 ! loop boundaries -! -!------------------------------------------------------------------------------- - -!$acc data present( PA, PMZF4 ) -! -!* 1. DEFINITION OF MZF4 -! ------------------ -! -IIU = SIZE(PA,1) -IJU = SIZE(PA,2) -IKU = SIZE(PA,3) -! -IIJU = IIU*IJU -! -JIJKOR1 = 1 + IIJU -JIJKEND1 = 2*IIJU -! -!$acc kernels -!CDIR NODEP -!OCL NOVREC -DO JIJK=JIJKOR1 , JIJKEND1 - PMZF4(JIJK-IIJU,1,1) = 0.5*( PA(JIJK-IIJU,1,1)+PA(JIJK,1,1) ) -END DO -! -JIJKOR2 = 1 + JIJKEND1 -JIJKEND2 = IIJU*IKU - IIJU -! -!CDIR NODEP -!OCL NOVREC -DO JIJK=JIJKOR2 , JIJKEND2 - PMZF4(JIJK-IIJU,1,1) = (7.0*( PA(JIJK,1,1)+PA(JIJK-IIJU,1,1) ) - & - ( PA(JIJK+IIJU,1,1)+PA(JIJK-2*IIJU,1,1) ) )/12.0 -END DO -! -JIJKOR3 = 1 + JIJKEND2 -JIJKEND3 = IIJU*IKU -! -!CDIR NODEP -!OCL NOVREC -DO JIJK=JIJKOR3 , JIJKEND3 - PMZF4(JIJK-IIJU,1,1) = 0.5*( PA(JIJK-IIJU,1,1)+PA(JIJK,1,1) ) -END DO -! -!CDIR NODEP -!OCL NOVREC -DO JIJ=1,IIJU - PMZF4(JIJ,1,IKU) = -999. -END DO -!$acc end kernels - -!$acc end data - -!------------------------------------------------------------------------------- -! -#ifndef MNH_OPENACC - END FUNCTION MZF4 -#else - END SUBROUTINE MZF4 -#endif -! -!------------------------------------------------------------------------------- -! -! ################################ -#ifndef MNH_OPENACC - FUNCTION MZM4(PA) RESULT(PMZM4) -#else - SUBROUTINE MZM4(PA,PMZM4) -#endif -! ################################ -! -!!**** *MZM4* - 4th order Shuman operator : mean operator in z direction for a -!! mass variable -!! -!! PURPOSE -!! ------- -!! The purpose of this function is to compute a 4th order mean value -!! along the z direction (K index) for a field PA localized at a mass -!! point. The result is localized at a z-flux point (w point). -!! -!!** METHOD -!! ------ -!! The result PMZM4(:,:,k) is defined by -!! PMZM4(:,:,k)=0.5*(PA(:,:,k)+PA(:,:,k+1)) at k=2 and size(PA,3) -!! PMZM4(:,:,k)=-999. at k=1 -!! PMZM4(:,:,k)=7/12*(PA(:,:,k)+PA(:,:,k+1)) -!! -1/12*(PA(:,:,k-1)+PA(:,:,k+2)) elsewhere -!! -!! EXTERNAL -!! -------- -!! NONE -!! -!! IMPLICIT ARGUMENTS(PMEANX,PMEANY) -!! ------------------ -!! NONE -!! -!! REFERENCE -!! --------- -!! Book2 of documentation of Meso-NH (SHUMAN operators) -!! Technical specifications Report of The Meso-NH (chapters 3) -!! -!! AUTHOR -!! ------ -!! J.-P. Pinty * Lab Aerologie * -!! -!! MODIFICATIONS -!! ------------- -!! Original 25/10/05 -!! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -IMPLICIT NONE -! -!* 0.1 Declarations of argument and result -! -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass - ! localization -REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZM4 ! result at flux - ! localization -! -!* 0.2 Declarations of local variables -! -! -INTEGER :: JK ! loop index in z direction -INTEGER :: IKU ! upper bound in z direction of PA -! -INTEGER :: IIU,IJU,IIJU ! upper bounds in the x and y directions of PA -INTEGER :: JIJ,JIJK ! running loop indexes after linearisation -INTEGER :: JIJKOR1,JIJKEND1 ! loop boundaries -INTEGER :: JIJKOR2,JIJKEND2 ! loop boundaries -! -!------------------------------------------------------------------------------- - -!$acc data present( PA, PMZM4 ) -! -!* 1. DEFINITION OF MZM4 -! ------------------ -! -IIU = SIZE(PA,1) -IJU = SIZE(PA,2) -IKU = SIZE(PA,3) -! -IIJU = IIU*IJU -! -JIJKOR1 = 1 + IIJU -JIJKEND1 = JIJKOR1 + IIJU -! -!$acc kernels -!CDIR NODEP -!OCL NOVREC -DO JIJK=JIJKOR1 , JIJKEND1 - PMZM4(JIJK,1,1) = 0.5*( PA(JIJK,1,1)+PA(JIJK-IIJU,1,1) ) -END DO -! -JIJKOR2 = 1 + JIJKEND1 -JIJKEND2 = IIJU*IKU - IIJU -! -!CDIR NODEP -!OCL NOVREC -DO JIJK=JIJKOR2 , JIJKEND2 - PMZM4(JIJK,1,1) = (7.0*( PA(JIJK,1,1)+PA(JIJK-IIJU,1,1) ) - & - ( PA(JIJK+IIJU,1,1)+PA(JIJK-2*IIJU,1,1) ) )/12.0 -END DO -! -!CDIR NODEP -!OCL NOVREC -DO JIJ=1,IIJU - PMZM4(JIJ,1,IKU) = 0.5*( PA(JIJ,1,IKU)+PA(JIJ-IIJU,1,IKU) ) -END DO -! -!CDIR NODEP -!OCL NOVREC -DO JIJ=1,IIJU - PMZM4(JIJ,1,1) = -999. -END DO -!$acc end kernels - -!$acc end data - -!------------------------------------------------------------------------------- -! -#ifndef MNH_OPENACC - END FUNCTION MZM4 -#else - END SUBROUTINE MZM4 -#endif diff --git a/src/ZSOLVER/advection_uvw_cen.f90 b/src/ZSOLVER/advection_uvw_cen.f90 deleted file mode 100644 index a4055eda197f8a47a2aa2ab075f9a3c9336cf74c..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/advection_uvw_cen.f90 +++ /dev/null @@ -1,447 +0,0 @@ -!MNH_LIC Copyright 2013-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! ##################### - MODULE MODI_ADVECTION_UVW_CEN -! ##################### -! -INTERFACE - SUBROUTINE ADVECTION_UVW_CEN(HUVW_ADV_SCHEME, & - HLBCX, HLBCY, & - PTSTEP, KTCOUNT, & - PUM, PVM, PWM, & - PDUM, PDVM, PDWM, & - PUT, PVT, PWT, & - PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, & - PRUS,PRVS, PRWS, & -#ifndef MNH_OPENACC - TPHALO2MLIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! -USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -! -CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME -! -CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC -! -REAL, INTENT(IN) :: PTSTEP! time step -INTEGER, INTENT(IN) :: KTCOUNT -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM, PVM, PWM - ! Variables at t-dt -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDUM, PDVM, PDWM -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT , PVT , PWT, PRHODJ -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZX,PDZY - ! metric coefficients -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS , PRVS , PRWS - ! Sources terms -! -! halo lists for 4th order advection -#ifndef MNH_OPENACC -TYPE(HALO2LIST_ll), POINTER :: TPHALO2MLIST ! momentum variables -#else -TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT -#endif -! -END SUBROUTINE ADVECTION_UVW_CEN -! -END INTERFACE -! -END MODULE MODI_ADVECTION_UVW_CEN -! ########################################################################## - SUBROUTINE ADVECTION_UVW_CEN(HUVW_ADV_SCHEME, & - HLBCX, HLBCY, & - PTSTEP, KTCOUNT, & - PUM, PVM, PWM, & - PDUM, PDVM, PDWM, & - PUT, PVT, PWT, & - PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, & - PRUS,PRVS, PRWS, & -#ifndef MNH_OPENACC - TPHALO2MLIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! ########################################################################## -! -!!**** *ADVECTION * - routine to call the specialized advection routines -!! -!! PURPOSE -!! ------- -!! The purpose of this routine is to control the advection routines. -!! For that, it is first necessary to compute the metric coefficients -!! and the contravariant components of the momentum. -!! -!!** METHOD -!! ------ -!! The advection of momenta is calculated using a centred (second order) -!! scheme. -!! -!! EXTERNAL -!! -------- -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! NONE -!! -!! REFERENCE -!! --------- -!! Book1 and book2 ( routine ADVECTION ) -!! -!! AUTHOR -!! ------ -!! V. Masson * Meteo France * -!! -!! MODIFICATIONS -!! ------------- -!! Original 01/2013 (from ADVECTION routine) -!! Modif -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test -! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine -! P. Wautelet 02/2020: use the new data structures and subroutines for budgets -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll -USE MODD_CONF -use modd_budget, only: lbudget_u, lbudget_v, lbudget_w, NBUDGET_U, NBUDGET_V, NBUDGET_W, tbudgets -USE MODD_GRID_n - -use mode_budget, only: Budget_store_init, Budget_store_end -USE MODE_ll -#ifdef MNH_OPENACC -USE MODE_DEVICE -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -use mode_msg -#endif -use mode_mppdb - -USE MODI_ADVECUVW_2ND -USE MODI_ADVECUVW_4TH -USE MODI_CONTRAV -#ifndef MNH_OPENACC -USE MODI_SHUMAN -#else -USE MODI_SHUMAN_DEVICE -#endif -!------------------------------------------------------------------------------- -! -IMPLICIT NONE -! -!* 0.1 Declarations of dummy arguments : -! -CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME -! -CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC -! -REAL, INTENT(IN) :: PTSTEP! time step -INTEGER, INTENT(IN) :: KTCOUNT -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM, PVM, PWM - ! Variables at t-dt -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDUM, PDVM, PDWM -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT , PVT , PWT, PRHODJ -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZX,PDZY - ! metric coefficients -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS , PRVS , PRWS - ! Sources terms -! -! halo lists for 4th order advection -#ifndef MNH_OPENACC -TYPE(HALO2LIST_ll), POINTER :: TPHALO2MLIST ! momentum variables -#else -TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT -#endif -! -! -!* 0.2 declarations of local variables -! -! -INTEGER :: IIU, IJU, IKU -#ifndef MNH_OPENACC -REAL, DIMENSION(:,:,:), allocatable :: ZUS -REAL, DIMENSION(:,:,:), allocatable :: ZVS -REAL, DIMENSION(:,:,:), allocatable :: ZWS - ! guess of cartesian components of - ! momentum at future (+PTSTEP) timestep -REAL, DIMENSION(:,:,:), allocatable :: ZRUS -REAL, DIMENSION(:,:,:), allocatable :: ZRVS -REAL, DIMENSION(:,:,:), allocatable :: ZRWS - ! cartesian components of - ! rhodJ times the tendency of - ! momentum from previous (-PTSTEP) - ! to future (+PTSTEP) timestep -! -REAL, DIMENSION(:,:,:), allocatable :: ZRUT -REAL, DIMENSION(:,:,:), allocatable :: ZRVT -REAL, DIMENSION(:,:,:), allocatable :: ZRWT - ! cartesian - ! components of - ! momentum -! -REAL, DIMENSION(:,:,:), allocatable :: ZRUCT -REAL, DIMENSION(:,:,:), allocatable :: ZRVCT -REAL, DIMENSION(:,:,:), allocatable :: ZRWCT - ! contravariant - ! components - ! of momentum -REAL, DIMENSION(:,:,:), allocatable :: ZMXM_RHODJ -REAL, DIMENSION(:,:,:), allocatable :: ZMYM_RHODJ -REAL, DIMENSION(:,:,:), allocatable :: ZMZM_RHODJ -#else -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZUS -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZVS -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZWS - ! guess of cartesian components of - ! momentum at future (+PTSTEP) timestep -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRUS -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRVS -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRWS - ! cartesian components of - ! rhodJ times the tendency of - ! momentum from previous (-PTSTEP) - ! to future (+PTSTEP) timestep -! -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRUT -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRVT -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRWT - ! cartesian - ! components of - ! momentum -! -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRUCT -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRVCT -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZRWCT - ! contravariant - ! components - ! of momentum -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZMXM_RHODJ -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZMYM_RHODJ -REAL, DIMENSION(:,:,:), pointer, contiguous :: ZMZM_RHODJ -#endif -! -INTEGER :: IINFO_ll ! return code of parallel routine -TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange -! -!------------------------------------------------------------------------------- -!$acc data present( PUM, PVM, PWM, PDUM, PDVM, PDWM, PUT, PVT, PWT, PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, PRUS, PRVS, PRWS ) - -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PUM,"ADVECTION_UVW_CEN beg:PUM") - CALL MPPDB_CHECK(PVM,"ADVECTION_UVW_CEN beg:PVM") - CALL MPPDB_CHECK(PWM,"ADVECTION_UVW_CEN beg:PWM") - CALL MPPDB_CHECK(PDUM,"ADVECTION_UVW_CEN beg:PDUM") - CALL MPPDB_CHECK(PDVM,"ADVECTION_UVW_CEN beg:PDVM") - CALL MPPDB_CHECK(PDWM,"ADVECTION_UVW_CEN beg:PDWM") - CALL MPPDB_CHECK(PUT,"ADVECTION_UVW_CEN beg:PUT") - CALL MPPDB_CHECK(PVT,"ADVECTION_UVW_CEN beg:PVT") - CALL MPPDB_CHECK(PWT,"ADVECTION_UVW_CEN beg:PWT") - CALL MPPDB_CHECK(PRHODJ,"ADVECTION_UVW_CEN beg:PRHODJ") - CALL MPPDB_CHECK(PDXX,"ADVECTION_UVW_CEN beg:PDXX") - CALL MPPDB_CHECK(PDYY,"ADVECTION_UVW_CEN beg:PDYY") - CALL MPPDB_CHECK(PDZZ,"ADVECTION_UVW_CEN beg:PDZZ") - CALL MPPDB_CHECK(PDZX,"ADVECTION_UVW_CEN beg:PDZX") - CALL MPPDB_CHECK(PDZY,"ADVECTION_UVW_CEN beg:PDZY") - !Check all INOUT arrays - CALL MPPDB_CHECK(PRUS,"ADVECTION_UVW_CEN beg:PRUS") - CALL MPPDB_CHECK(PRVS,"ADVECTION_UVW_CEN beg:PRVS") - CALL MPPDB_CHECK(PRWS,"ADVECTION_UVW_CEN beg:PRWS") -END IF - -if ( lbudget_u ) call Budget_store_init( tbudgets(NBUDGET_U), 'ADV', prus(:, :, :) ) -if ( lbudget_v ) call Budget_store_init( tbudgets(NBUDGET_V), 'ADV', prvs(:, :, :) ) -if ( lbudget_w ) call Budget_store_init( tbudgets(NBUDGET_W), 'ADV', prws(:, :, :) ) - -IIU = SIZE( put, 1 ) -IJU = SIZE( put, 2 ) -IKU = SIZE( put, 3 ) - -#ifndef MNH_OPENACC -allocate( zus ( iiu, iju, iku ) ) -allocate( zvs ( iiu, iju, iku ) ) -allocate( zws ( iiu, iju, iku ) ) -allocate( zrus ( iiu, iju, iku ) ) -allocate( zrvs ( iiu, iju, iku ) ) -allocate( zrws ( iiu, iju, iku ) ) -allocate( zrut ( iiu, iju, iku ) ) -allocate( zrvt ( iiu, iju, iku ) ) -allocate( zrwt ( iiu, iju, iku ) ) -allocate( zruct ( iiu, iju, iku ) ) -allocate( zrvct ( iiu, iju, iku ) ) -allocate( zrwct ( iiu, iju, iku ) ) -allocate( zmxm_rhodj ( iiu, iju, iku ) ) -allocate( zmym_rhodj ( iiu, iju, iku ) ) -allocate( zmzm_rhodj ( iiu, iju, iku ) ) -#else -!Pin positions in the pools of MNH memory -CALL MNH_MEM_POSITION_PIN( 'ADVECTION_UVW_CEN' ) - -CALL MNH_MEM_GET( zus, iiu, iju, iku ) -CALL MNH_MEM_GET( zvs, iiu, iju, iku ) -CALL MNH_MEM_GET( zws, iiu, iju, iku ) -CALL MNH_MEM_GET( zrus, iiu, iju, iku ) -CALL MNH_MEM_GET( zrvs, iiu, iju, iku ) -CALL MNH_MEM_GET( zrws, iiu, iju, iku ) -CALL MNH_MEM_GET( zrut, iiu, iju, iku ) -CALL MNH_MEM_GET( zrvt, iiu, iju, iku ) -CALL MNH_MEM_GET( zrwt, iiu, iju, iku ) -CALL MNH_MEM_GET( zruct, iiu, iju, iku ) -CALL MNH_MEM_GET( zrvct, iiu, iju, iku ) -CALL MNH_MEM_GET( zrwct, iiu, iju, iku ) -CALL MNH_MEM_GET( zmxm_rhodj, iiu, iju, iku ) -CALL MNH_MEM_GET( zmym_rhodj, iiu, iju, iku ) -CALL MNH_MEM_GET( zmzm_rhodj, iiu, iju, iku ) - -!$acc data present( zus, zvs, zws, zrus, zrvs, zrws, zrut, zrvt, zrwt, & -!$acc & zruct, zrvct, zrwct, zmxm_rhodj, zmym_rhodj, zmzm_rhodj ) -#endif - -#ifdef MNH_OPENACC -CALL INIT_ON_HOST_AND_DEVICE(ZUS,-1e99,'ADVECTION_UVW_CEN::ZUS') -CALL INIT_ON_HOST_AND_DEVICE(ZVS,-2e99,'ADVECTION_UVW_CEN::ZVS') -CALL INIT_ON_HOST_AND_DEVICE(ZWS,-3e99,'ADVECTION_UVW_CEN::ZWS') -CALL INIT_ON_HOST_AND_DEVICE(ZRUS,-1e99,'ADVECTION_UVW_CEN::ZRUS') -CALL INIT_ON_HOST_AND_DEVICE(ZRVS,-2e99,'ADVECTION_UVW_CEN::ZRVS') -CALL INIT_ON_HOST_AND_DEVICE(ZRWS,-3e99,'ADVECTION_UVW_CEN::ZRWS') -CALL INIT_ON_HOST_AND_DEVICE(ZRUT,-1e99,'ADVECTION_UVW_CEN::ZRUT') -CALL INIT_ON_HOST_AND_DEVICE(ZRVT,-2e99,'ADVECTION_UVW_CEN::ZRVT') -CALL INIT_ON_HOST_AND_DEVICE(ZRWT,-3e99,'ADVECTION_UVW_CEN::ZRWT') -CALL INIT_ON_HOST_AND_DEVICE(ZRUCT,-1e98,'ADVECTION_UVW_CEN::ZRUCT') -CALL INIT_ON_HOST_AND_DEVICE(ZRVCT,-2e98,'ADVECTION_UVW_CEN::ZRVCT') -CALL INIT_ON_HOST_AND_DEVICE(ZRWCT,-3e98,'ADVECTION_UVW_CEN::ZRWCT') -CALL INIT_ON_HOST_AND_DEVICE(ZMXM_RHODJ,-1e97,'ADVECTION_UVW_CEN::ZMXM_RHODJ') -CALL INIT_ON_HOST_AND_DEVICE(ZMYM_RHODJ,-2e97,'ADVECTION_UVW_CEN::ZMYM_RHODJ') -CALL INIT_ON_HOST_AND_DEVICE(ZMZM_RHODJ,-3e97,'ADVECTION_UVW_CEN::ZMZM_RHODJ') -#endif - -#ifndef MNH_OPENACC -ZMXM_RHODJ = MXM(PRHODJ) -ZMYM_RHODJ = MYM(PRHODJ) -ZMZM_RHODJ = MZM(PRHODJ) -#else -CALL MXM_DEVICE(PRHODJ,ZMXM_RHODJ) -CALL MYM_DEVICE(PRHODJ,ZMYM_RHODJ) -CALL MZM_DEVICE(PRHODJ,ZMZM_RHODJ) -#endif -! -!* 1. COMPUTES THE CONTRAVARIANT COMPONENTS -! ------------------------------------- -! -!$acc kernels present(ZRUT,ZRVT,ZRWT,PUT,PVT,PWT,ZMXM_RHODJ,ZMYM_RHODJ,ZMZM_RHODJ) -ZRUT(:,:,:) = PUT(:,:,:) * ZMXM_RHODJ(:,:,:) -ZRVT(:,:,:) = PVT(:,:,:) * ZMYM_RHODJ(:,:,:) -ZRWT(:,:,:) = PWT(:,:,:) * ZMZM_RHODJ(:,:,:) -!$acc end kernels -! -#ifndef MNH_OPENACC -IF (HUVW_ADV_SCHEME=='CEN2ND' ) THEN - CALL CONTRAV (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,2) -ELSEIF (HUVW_ADV_SCHEME=='CEN4TH') THEN - CALL CONTRAV (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,4) -END IF -#else -IF (HUVW_ADV_SCHEME=='CEN2ND' ) THEN - CALL CONTRAV_DEVICE (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,2, & - ODATA_ON_DEVICE=.TRUE.) -ELSEIF (HUVW_ADV_SCHEME=='CEN4TH') THEN - CALL CONTRAV_DEVICE (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,4, & - ODATA_ON_DEVICE=.TRUE.) -END IF -!Not necessary: already done in contrav_device !$acc update self(ZRUCT,ZRVCT,ZRWCT) -#endif -! -NULLIFY(TZFIELDS_ll) -!!$IF(NHALO == 1) THEN - CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRWCT, 'ADVECTION_UVW_CEN::ZRWCT' ) - CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRUCT, 'ADVECTION_UVW_CEN::ZRUCT' ) - CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRVCT, 'ADVECTION_UVW_CEN::ZRVCT' ) - CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll) - CALL CLEANLIST_ll(TZFIELDS_ll) - !$acc update device(ZRUCT, ZRVCT, ZRWCT) -!!$END IF -! -!------------------------------------------------------------------------------- -! -!* 2. TERM FROM PREVIOUS TIME-STEP (from initial_guess) -! ---------------------------- -! -!$acc kernels present(ZRUS,ZRVS,ZRWS,PUM,PVM,PWM,ZMXM_RHODJ,ZMYM_RHODJ,ZMZM_RHODJ) -ZRUS(:,:,:) = PUM(:,:,:) * ZMXM_RHODJ(:,:,:)/(2.*PTSTEP) -ZRVS(:,:,:) = PVM(:,:,:) * ZMYM_RHODJ(:,:,:)/(2.*PTSTEP) -ZRWS(:,:,:) = PWM(:,:,:) * ZMZM_RHODJ(:,:,:)/(2.*PTSTEP) -!$acc end kernels -! -!------------------------------------------------------------------------------- -! -!* 3. CALLS THE ADVECTION ROUTINES FOR THE MOMENTUM -! --------------------------------------------- -! -! choose between 2nd and 4th order momentum advection. -IF (HUVW_ADV_SCHEME=='CEN2ND' ) THEN -! -#ifdef MNH_OPENACC - call Print_msg( NVERB_ERROR, 'GEN', 'ADVECTION_UVW_CEN', 'OpenACC: CEN2ND not yet implemented' ) -#endif - CALL ADVECUVW_2ND (PUT,PVT,PWT,ZRUCT,ZRVCT,ZRWCT,ZRUS,ZRVS,ZRWS) -! -ELSEIF (HUVW_ADV_SCHEME=='CEN4TH') THEN -! - CALL ADVECUVW_4TH ( HLBCX, HLBCY, ZRUCT, ZRVCT, ZRWCT, & - PUT, PVT, PWT, ZRUS, ZRVS, ZRWS, & -#ifndef MNH_OPENACC - TPHALO2MLIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! -END IF -! -!$acc kernels present(ZRUS,ZRVS,ZRWS,ZMXM_RHODJ,ZMYM_RHODJ,ZMZM_RHODJ) & -!$acc present_cr(PRUS,PRVS,PRWS,PDUM,PDWM) -ZUS(:,:,:) = ZRUS(:,:,:)/ZMXM_RHODJ(:,:,:)*2.*PTSTEP -ZVS(:,:,:) = ZRVS(:,:,:)/ZMYM_RHODJ(:,:,:)*2.*PTSTEP -ZWS(:,:,:) = ZRWS(:,:,:)/ZMZM_RHODJ(:,:,:)*2.*PTSTEP -!------------------------------------------------------------------------------- -! -!* 5. Extracts the variation between current and future time step -! ----------------------------------------------------------- -! -PRUS(:,:,:) = PRUS(:,:,:) + ( ZUS(:,:,:) - PUM(:,:,:) - 0.5* PDUM(:,:,:)) * ZMXM_RHODJ(:,:,:)/(PTSTEP) -PRVS(:,:,:) = PRVS(:,:,:) + ( ZVS(:,:,:) - PVM(:,:,:) - 0.5* PDVM(:,:,:)) * ZMYM_RHODJ(:,:,:)/(PTSTEP) -PRWS(:,:,:) = PRWS(:,:,:) + ( ZWS(:,:,:) - PWM(:,:,:) - 0.5* PDWM(:,:,:)) * ZMZM_RHODJ(:,:,:)/(PTSTEP) -! -PDUM(:,:,:) = ZUS(:,:,:) - PUM(:,:,:) -PDVM(:,:,:) = ZVS(:,:,:) - PVM(:,:,:) -PDWM(:,:,:) = ZWS(:,:,:) - PWM(:,:,:) -!$acc end kernels - -if ( lbudget_u ) call Budget_store_end( tbudgets(NBUDGET_U), 'ADV', prus(:, :, :) ) -if ( lbudget_v ) call Budget_store_end( tbudgets(NBUDGET_V), 'ADV', prvs(:, :, :) ) -if ( lbudget_w ) call Budget_store_end( tbudgets(NBUDGET_W), 'ADV', prws(:, :, :) ) - -IF (MPPDB_INITIALIZED) THEN - !Check all INOUT arrays - CALL MPPDB_CHECK(PRUS,"ADVECTION_UVW_CEN end:PRUS") - CALL MPPDB_CHECK(PRVS,"ADVECTION_UVW_CEN end:PRVS") - CALL MPPDB_CHECK(PRWS,"ADVECTION_UVW_CEN end:PRWS") -END IF - -!$acc end data - -#ifdef MNH_OPENACC -!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN -CALL MNH_MEM_RELEASE( 'ADVECTION_UVW_CEN' ) -#endif - -!$acc end data - -!------------------------------------------------------------------------------- -! -END SUBROUTINE ADVECTION_UVW_CEN diff --git a/src/ZSOLVER/advecuvw_4th.f90 b/src/ZSOLVER/advecuvw_4th.f90 deleted file mode 100644 index 5705d338cd931d3d5e538cc72088273bcbcfbb92..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/advecuvw_4th.f90 +++ /dev/null @@ -1,412 +0,0 @@ -!MNH_LIC Copyright 2005-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! ########################### - MODULE MODI_ADVECUVW_4TH -! ########################### -! -INTERFACE -! - SUBROUTINE ADVECUVW_4TH ( HLBCX, HLBCY, PRUCT, PRVCT, PRWCT, & - PUT, PVT, PWT, PRUS, PRVS, PRWS, & -#ifndef MNH_OPENACC - TPHALO2LIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! -USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT ! contravariant -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVCT ! components -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWCT ! of momentum -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT, PWT ! U,V,W at t -! -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS ! Source terms -! -#ifndef MNH_OPENACC -TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list for diffusion -#else -TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT -#endif -! -END SUBROUTINE ADVECUVW_4TH -! -END INTERFACE -! -END MODULE MODI_ADVECUVW_4TH -! -! -! ###################################################################### - SUBROUTINE ADVECUVW_4TH ( HLBCX, HLBCY, PRUCT, PRVCT, PRWCT, & - PUT, PVT, PWT, PRUS, PRVS, PRWS, & -#ifndef MNH_OPENACC - TPHALO2LIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! ###################################################################### -! -!!**** *ADVECUVW_4TH * - routine to compute the 4th order centered -!! advection tendency of momentum (U,V,W) -!! -!! PURPOSE -!! ------- -!! The purpose of this routine is to call the ADVEC_4TH_ORDER_ALGO -!! routine for the horizontal advection and the MZM4 and MZF4 functions for -!! the vertical advection of momentum. The code is -!! parallelized and works for various boundary conditions. -!! -!!** METHOD -!! ------ -!! For each wind component the ADVECUVW_4TH routine calls -!! the ADVEC_4TH_ORDER_ALGO routine which computes the numerical advection -!! of any 3D field. -!! The following variables are passed as argument to ADVEC_4TH_ORDER_ALGO : -!! -!! -- The variable at t -!! -- The second layer of the halo of the field at t -!! -- The horizontal advection fluxes -!! -- The localisation on the model grid : -!! -!! IGRID = 1 for mass grid point -!! IGRID = 2 for U grid point -!! IGRID = 3 for V grid point -!! IGRID = 4 for W grid point -!! -!! EXTERNAL -!! -------- -!! BUDGET : Stores the different budget components -!! (not used in current version) -!! ADVEC_4TH_ORDER_ALGO : computes the horizontal advection fluxes -!! MZF4 and MZM4 : computes the vertical advection fluxes -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! MODULE MODD_BUDGET: -!! NBUMOD : model in which budget is calculated -!! CBUTYPE : type of desired budget -!! 'CART' for cartesian box configuration -!! 'MASK' for budget zone defined by a mask -!! 'NONE' ' for no budget -!! NBUPROCCTR : process counter used for each budget variable -!! Switches for budgets activations: -!! -!! MODULE MODD_ARGSLIST -!! HALO2LIST_ll : type for a list of "HALO2_lls" -!! -!! REFERENCE -!! --------- -!! Book2 of documentation ( routine ADVECUVW_4TH ) -!! -!! AUTHOR -!! ------ -!! J.-P. Pinty * Laboratoire d'Aerologie* -!! -!! MODIFICATIONS -!! ------------- -!! Original 25/10/05 -!! Modif -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test -!! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -USE MODD_CONF -USE MODD_GRID_n -USE MODD_PARAMETERS - -USE MODE_ll -#ifdef MNH_OPENACC -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -#endif -use mode_mppdb - -USE MODI_ADVEC_4TH_ORDER_AUX -#ifndef MNH_OPENACC -USE MODI_SHUMAN -#else -USE MODI_SHUMAN_DEVICE -#endif -! -IMPLICIT NONE -! -!* 0.1 Declarations of dummy arguments : -! -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -! -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT ! contravariant -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVCT ! components -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWCT ! of momentum -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT, PWT ! Variables at t -! -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS ! Source terms -! -#ifndef MNH_OPENACC -TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list for diffusion -#else -TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT -#endif -! -!* 0.2 Declarations of local variables : -! -TYPE(HALO2LIST_ll), POINTER :: TZHALO2LIST -! -INTEGER :: IGRID ! localisation on the model grid -#ifndef MNH_OPENACC -REAL, DIMENSION(SIZE(PUT,1),SIZE(PUT,2),SIZE(PUT,3)) :: ZMEANX, ZMEANY ! fluxes -#else -INTEGER :: IIU, IJU, IKU -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZMEANX, ZMEANY ! fluxes -! -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZTEMP1, ZTEMP2, ZTEMP3, ZTEMP4 -#endif -! -#if 0 -#define dxm(PDXM,PA) PDXM(2:IIU,:,:) = PA(2:IIU,:,:) - PA(1:IIU-1,:,:) ; PDXM(1,:,:) = PDXM(IIU-2*JPHEXT+1,:,:) ! DXM(PDXM,PA) -#define mxf(PMXF,PA) PMXF(1:IIU-1,:,:) = 0.5*( PA(2:IIU,:,:)+PA(1:IIU-1,:,:) ) ; PMXF(IIU,:,:) = PMXF(2*JPHEXT,:,:) ! MXF(PMXF,PA) -#define mxm(PMXM,PA) PMXM(2:IIU,:,:) = 0.5*( PA(2:IIU,:,:)+PA(1:IIU-1,:,:) ) ; PMXM(1,:,:) = PMXM(IIU-2*JPHEXT+1,:,:) ! MXM(PMXM,PA) -#define dyf(PDYF,PA) PDYF(:,1:IJU-1,:) = PA(:,2:IJU,:) - PA(:,1:IJU-1,:) ; PDYF(:,IJU,:) = PDYF(:,2*JPHEXT,:) ! DYF(PDYF,PA) -#define dzf(PDZF,PA) PDZF(:,:,1:IKU-1) = PA(:,:,2:IKU) - PA(:,:,1:IKU-1) ; PDZF(:,:,IKU) = -999. ! DZF(PDZF,PA) -#define mzm4(PMZM4,PA) PMZM4(:,:,3:IKU-1) = (7.0*( PA(:,:,3:IKU-1)+PA(:,:,2:IKU-2) ) - (PA(:,:,4:IKU)+PA(:,:,1:IKU-3) ) )/12.0 ; \ - PMZM4(:,:,2) = 0.5*( PA(:,:,2)+PA(:,:,1) ) ; PMZM4(:,:,IKU) = 0.5*( PA(:,:,IKU)+PA(:,:,IKU-1) ) ; PMZM4(:,:,1) = -999. -#define mym(PMYM,PA) PMYM(:,2:IJU,:) = 0.5*( PA(:,2:IJU,:)+PA(:,1:IJU-1,:) ) ; PMYM(:,1,:) = PMYM(:,IJU-2*JPHEXT+1,:) ! MYM(PMYM,PA) -#define dxf(PDXF,PA) PDXF(1:IIU-1,:,:) = PA(2:IIU,:,:) - PA(1:IIU-1,:,:) ; PDXF(IIU,:,:) = PDXF(2*JPHEXT,:,:) ! DXF(PDXF,PA) -#define myf(PMYF,PA) PMYF(:,1:IJU-1,:) = 0.5*( PA(:,1:IJU-1,:)+PA(:,2:IJU,:) ) ; PMYF(:,IJU,:) = PMYF(:,2*JPHEXT,:) ! MYF(PMYF,PA) -#define dym(PDYM,PA) PDYM(:,2:IJU,:) = PA(:,2:IJU,:) - PA(:,1:IJU-1,:) ; PDYM(:,1,:) = PDYM(:,IJU-2*JPHEXT+1,:) ! DYM(PDYM,PA) -#define mzm(PMZM,PA) PMZM(:,:,2:IKU) = 0.5*( PA(:,:,2:IKU)+PA(:,:,1:IKU-1) ) ; PMZM(:,:,1) = -999. ! MZM(PMZM,PA) -#define mzf(PMZF,PA) PMZF(:,:,1:IKU-1) = 0.5*( PA(:,:,1:IKU-1)+PA(:,:,2:IKU) ) ; PMZF(:,:,IKU) = -999. ! MZF(PMZF,PA) -#define dzm(PDZM,PA) PDZM(:,:,2:IKU) = PA(:,:,2:IKU) - PA(:,:,1:IKU-1) ; PDZM(:,:,1) = -999. ! DZM(PDZM,PA) -#define mzf4(PMZF4,PA) PMZF4(:,:,2:IKU-2) = (7.0*( PA(:,:,3:IKU-1)+PA(:,:,2:IKU-2) ) - (PA(:,:,4:IKU)+PA(:,:,1:IKU-3) ) )/12.0 ; \ - PMZF4(:,:,1) = 0.5*( PA(:,:,2)+PA(:,:,1) ) ; PMZF4(:,:,IKU-1) = 0.5*( PA(:,:,IKU)+PA(:,:,IKU-1) ) ; PMZF4(:,:,IKU) = -999. -#endif -! -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PRUCT,"ADVECUVW_4TH beg:PRUCT") - CALL MPPDB_CHECK(PRVCT,"ADVECUVW_4TH beg:PRVCT") - CALL MPPDB_CHECK(PRWCT,"ADVECUVW_4TH beg:PRWCT") - CALL MPPDB_CHECK(PUT,"ADVECUVW_4TH beg:PUT") - CALL MPPDB_CHECK(PVT,"ADVECUVW_4TH beg:PVT") - CALL MPPDB_CHECK(PWT,"ADVECUVW_4TH beg:PWT") - !Check all INOUT arrays - CALL MPPDB_CHECK(PRUS,"ADVECUVW_4TH beg:PRUS") - CALL MPPDB_CHECK(PRVS,"ADVECUVW_4TH beg:PRVS") - CALL MPPDB_CHECK(PRWS,"ADVECUVW_4TH beg:PRWS") -END IF - -#ifdef MNH_OPENACC -IIU = SIZE( PUT, 1 ) -IJU = SIZE( PUT, 2 ) -IKU = SIZE( PUT, 3 ) - -!Pin positions in the pools of MNH memory -CALL MNH_MEM_POSITION_PIN() - -CALL MNH_MEM_GET( ZMEANX, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZMEANY, IIU, IJU, IKU ) - -CALL MNH_MEM_GET( ZTEMP1, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZTEMP2, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZTEMP3, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZTEMP4, IIU, IJU, IKU ) -#endif - -!$acc data present( PRUCT, PRVCT, PRWCT, PUT, PVT, PWT, PRUS, PRVS, PRWS, ZMEANX, ZMEANY, ZTEMP1, ZTEMP2, ZTEMP3, ZTEMP4 ) - -!------------------------------------------------------------------------------- -! -!* 2. CALL THE ADVEC_4TH_ORDER_ALGO ROUTINE FOR MOMENTUM -! -------------------------------------------------- -! -IGRID = 2 -!!$IF(NHALO == 1) THEN -#ifndef MNH_OPENACC - TZHALO2LIST => TPHALO2LIST -#else - TZHALO2LIST => TPHALO2_UT -#endif - CALL ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PUT, IGRID, ZMEANX, ZMEANY, & - TZHALO2LIST%HALO2 ) -!!$ELSE -!!$ CALL ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PUT, IGRID, ZMEANX, ZMEANY) -!!$ENDIF -! -#ifndef MNH_OPENACC -PRUS(:,:,:) = PRUS(:,:,:) & - -DXM( MXF(PRUCT(:,:,:))*ZMEANX(:,:,:) ) -! -PRUS(:,:,:) = PRUS(:,:,:) & - -DYF( MXM(PRVCT(:,:,:))*ZMEANY(:,:,:) ) -! -PRUS(:,:,:) = PRUS(:,:,:) & - -DZF( MXM(PRWCT(:,:,:))*MZM4(PUT(:,:,:)) ) -#else -call mxf_device(PRUCT,ZTEMP1) -!$acc kernels -ZTEMP2 = ZTEMP1 * ZMEANX -!$acc end kernels -call dxm_device(ZTEMP2,ZTEMP3) -!$acc kernels -PRUS(:,:,:) = PRUS(:,:,:) - ZTEMP3 -!$acc end kernels -! -call mxm_device(PRVCT,ZTEMP1) -!$acc kernels -ZTEMP2 = ZTEMP1 * ZMEANY -!$acc end kernels -call dyf_device(ZTEMP2,ZTEMP3) -!$acc kernels -PRUS(:,:,:) = PRUS(:,:,:) - ZTEMP3 -!$acc end kernels -! -call MZM4( PUT , ZTEMP1 ) -call mxm_device(PRWCT,ZTEMP2) -!$acc kernels -ZTEMP3 = ZTEMP1 * ZTEMP2 -!$acc end kernels -call dzf_device( ZTEMP3, ZTEMP4 ) -!$acc kernels -PRUS(:,:,:) = PRUS(:,:,:) - ZTEMP4 -!$acc end kernels -#endif -! -! -IGRID = 3 -!!$IF(NHALO == 1) THEN -#ifndef MNH_OPENACC - TZHALO2LIST => TZHALO2LIST%NEXT -#else - TZHALO2LIST => TPHALO2_VT -#endif - CALL ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PVT, IGRID, ZMEANX, ZMEANY, & - TZHALO2LIST%HALO2 ) -!!$ELSE -!!$ CALL ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PVT, IGRID, ZMEANX, ZMEANY) -!!$ENDIF -! -#ifndef MNH_OPENACC -PRVS(:,:,:) = PRVS(:,:,:) & - -DXF( MYM(PRUCT(:,:,:))*ZMEANX(:,:,:) ) -! -PRVS(:,:,:) = PRVS(:,:,:) & - -DYM( MYF(PRVCT(:,:,:))*ZMEANY(:,:,:) ) -! -PRVS(:,:,:) = PRVS(:,:,:) & - -DZF( MYM(PRWCT(:,:,:))*MZM4(PVT(:,:,:)) ) -#else -call mym_device(PRUCT,ZTEMP1) -!$acc kernels -ZTEMP2 = ZTEMP1 * ZMEANX -!$acc end kernels -call dxf_device(ZTEMP2,ZTEMP3) -!$acc kernels -PRVS(:,:,:) = PRVS(:,:,:) - ZTEMP3 -!$acc end kernels -! -call myf_device(PRVCT,ZTEMP1) -!$acc kernels -ZTEMP2 = ZTEMP1 * ZMEANY -!$acc end kernels -call dym_device(ZTEMP2,ZTEMP3) -!$acc kernels -PRVS(:,:,:) = PRVS(:,:,:) - ZTEMP3 -!$acc end kernels -! -call mym_device(PRWCT,ZTEMP1) -CALL MZM4( PVT , ZTEMP2) -!$acc kernels -ZTEMP3 = ZTEMP1 * ZTEMP2 -!$acc end kernels -call dzf_device( ZTEMP3, ZTEMP4 ) -!$acc kernels -PRVS(:,:,:) = PRVS(:,:,:) - ZTEMP4 -!$acc end kernels -#endif -CALL MPPDB_CHECK(PRUCT,"ADVECUVW_4TH 02: PRUCT") -! -! -IGRID = 4 -! -!!$IF(NHALO == 1) THEN -#ifndef MNH_OPENACC - TZHALO2LIST => TZHALO2LIST%NEXT -#else - TZHALO2LIST => TPHALO2_WT -#endif - CALL ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PWT, IGRID, ZMEANX, ZMEANY, & - TZHALO2LIST%HALO2 ) -!!$ELSE -!!$ CALL ADVEC_4TH_ORDER_ALGO(HLBCX, HLBCY, PWT, IGRID, ZMEANX, ZMEANY) -!!$ENDIF -! -#ifndef MNH_OPENACC -PRWS(:,:,:) = PRWS(:,:,:) & - -DXF( MZM(PRUCT(:,:,:))*ZMEANX(:,:,:) ) -! -PRWS(:,:,:) = PRWS(:,:,:) & - -DYF( MZM(PRVCT(:,:,:))*ZMEANY(:,:,:) ) -! -PRWS(:,:,:) = PRWS(:,:,:) & - -DZM( MZF(PRWCT(:,:,:))*MZF4(PWT(:,:,:)) ) -#else -call mzm_device(PRUCT,ZTEMP1) -!$acc kernels -ZTEMP2 = ZTEMP1 * ZMEANX -!$acc end kernels -call dxf_device(ZTEMP2,ZTEMP3) -!$acc kernels -PRWS(:,:,:) = PRWS(:,:,:) - ZTEMP3 -!$acc end kernels -! -call mzm_device(PRVCT,ZTEMP1) -!$acc kernels -ZTEMP2 = ZTEMP1 * ZMEANY -!$acc end kernels -call dyf_device(ZTEMP2,ZTEMP3) -!$acc kernels -PRWS(:,:,:) = PRWS(:,:,:) - ZTEMP3 -!$acc end kernels -! -call mzf_device( PRWCT, ZTEMP1 ) -CALL MZF4( PWT , ZTEMP2 ) -!$acc kernels -ZTEMP1 = ZTEMP1 * ZTEMP2 -!$acc end kernels -call dzm_device( ZTEMP1, ZTEMP4 ) -!$acc kernels -PRWS(:,:,:) = PRWS(:,:,:) - ZTEMP4 -!$acc end kernels -#endif - -!$acc end data - -#ifdef MNH_OPENACC -!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN -CALL MNH_MEM_RELEASE() -#endif - -IF (MPPDB_INITIALIZED) THEN - !Check all INOUT arrays - CALL MPPDB_CHECK(PRUS,"ADVECUVW_4TH end:PRUS") - CALL MPPDB_CHECK(PRVS,"ADVECUVW_4TH end:PRVS") - CALL MPPDB_CHECK(PRWS,"ADVECUVW_4TH end:PRWS") -END IF - -!------------------------------------------------------------------------------- -! -! -END SUBROUTINE ADVECUVW_4TH diff --git a/src/ZSOLVER/advecuvw_rk.f90 b/src/ZSOLVER/advecuvw_rk.f90 deleted file mode 100644 index e702792924df7aca7e38368376c30c4c3ffb0b34..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/advecuvw_rk.f90 +++ /dev/null @@ -1,695 +0,0 @@ -!MNH_LIC Copyright 1994-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! ##################### - MODULE MODI_ADVECUVW_RK -! ##################### -! -INTERFACE - SUBROUTINE ADVECUVW_RK (HUVW_ADV_SCHEME, & - HTEMP_SCHEME, KWENO_ORDER, & - HLBCX, HLBCY, PTSTEP, & - PU, PV, PW, & - PUT, PVT, PWT, & - PMXM_RHODJ, PMYM_RHODJ, PMZM_RHODJ, & - PRUCT, PRVCT, PRWCT, & - PRUS_ADV, PRVS_ADV, PRWS_ADV, & - PRUS_OTHER, PRVS_OTHER, PRWS_OTHER ) -! -CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME! to the selected -CHARACTER(LEN=4), INTENT(IN) :: HTEMP_SCHEME ! Temporal scheme -! -INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO - ! scheme (3 or 5) -! -CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC -! -REAL, INTENT(IN) :: PTSTEP -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PU , PV , PW - ! Variables to advect -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT , PWT - ! Variables at t -REAL, DIMENSION(:,:,:), INTENT(IN) :: PMXM_RHODJ -REAL, DIMENSION(:,:,:), INTENT(IN) :: PMYM_RHODJ -REAL, DIMENSION(:,:,:), INTENT(IN) :: PMZM_RHODJ - ! metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT , PRVCT, PRWCT - ! Contravariant wind components -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUS_ADV , PRVS_ADV, PRWS_ADV - ! Tendency due to advection -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUS_OTHER , PRVS_OTHER, PRWS_OTHER -! ! tendencies from other processes -END SUBROUTINE ADVECUVW_RK -! -END INTERFACE -! -END MODULE MODI_ADVECUVW_RK -! ########################################################################## - SUBROUTINE ADVECUVW_RK (HUVW_ADV_SCHEME, & - HTEMP_SCHEME, KWENO_ORDER, & - HLBCX, HLBCY, PTSTEP, & - PU, PV, PW, & - PUT, PVT, PWT, & - PMXM_RHODJ, PMYM_RHODJ, PMZM_RHODJ, & - PRUCT, PRVCT, PRWCT, & - PRUS_ADV, PRVS_ADV, PRWS_ADV, & - PRUS_OTHER, PRVS_OTHER, PRWS_OTHER ) -! ########################################################################## -! -!!**** *ADVECUVW_RK * - routine to call the specialized advection routines for wind -!! -!! PURPOSE -!! ------- -!! -!!** METHOD -!! ------ -!! -!! EXTERNAL -!! -------- -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! NONE -!! -!! REFERENCE -!! --------- -!! Book1 and book2 ( routine ADVECTION ) -!! -!! AUTHOR -!! ------ -!! J.-P. Pinty * Laboratoire d'Aerologie* -!! J.-P. Lafore * Meteo France * -!! -!! MODIFICATIONS -!! ------------- -!! Original 06/07/94 -!! 01/04/95 (Ph. Hereil J. Nicolau) add the model number -!! 23/10/95 (J. Vila and JP Lafore) advection schemes scalar -!! 16/01/97 (JP Pinty) change presentation -!! 30/04/98 (J. Stein P Jabouille) extrapolation for the cyclic -!! case and parallelisation -!! 24/06/99 (P Jabouille) case of NHALO>1 -!! 25/10/05 (JP Pinty) 4th order scheme -!! 24/04/06 (C.Lac) Split scalar and passive -!! tracer routines -!! 08/06 (T.Maric) PPM scheme -!! 04/2011 (V. Masson & C. Lac) splits the routine and adds -!! time splitting -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test -!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 -!! F.Auguste and C.Lac : 08/16 : CEN4TH with RKC4 -!! C.Lac 10/16 : Correction on RK loop -! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg -! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine -! T. Nagel,F.Auguste 06/2021: add IBM -!! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_ARGSLIST_ll, ONLY: LIST_ll, HALO2LIST_ll -USE MODD_CONF, ONLY: NHALO -USE MODD_IBM_PARAM_n, ONLY: LIBM, XIBM_LS, XIBM_EPSI -USE MODD_IBM_PARAM_n, ONLY: MODD_CIBM_ADV => CIBM_ADV -USE MODD_PARAMETERS, ONLY: JPVEXT -USE MODD_SUB_MODEL_n, ONLY: XT_IBM_FORC -! -USE MODE_ll -USE MODE_MPPDB -use mode_msg -! -USE MODI_ADV_BOUNDARIES -USE MODI_ADVECUVW_2ND -USE MODI_ADVECUVW_4TH -USE MODI_ADVECUVW_WENO_K -USE MODI_GET_HALO -USE MODI_IBM_FORCING_ADV -USE MODI_SECOND_MNH -USE MODI_SHUMAN -! -! -#ifdef MNH_OPENACC -USE MODE_DEVICE -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -#endif -! -!------------------------------------------------------------------------------- -! -IMPLICIT NONE -! -!* 0.1 Declarations of dummy arguments : -! -CHARACTER(LEN=6), INTENT(IN) :: HUVW_ADV_SCHEME! to the selected -CHARACTER(LEN=4), INTENT(IN) :: HTEMP_SCHEME ! Temporal scheme -! -INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO - ! scheme (3 or 5) -! -CHARACTER(LEN=4),DIMENSION(2),INTENT(IN):: HLBCX, HLBCY ! X- and Y-direc LBC -! -REAL, INTENT(IN) :: PTSTEP -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PU , PV , PW - ! Variables to advect -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT , PWT - ! Variables at t -REAL, DIMENSION(:,:,:), INTENT(IN) :: PMXM_RHODJ -REAL, DIMENSION(:,:,:), INTENT(IN) :: PMYM_RHODJ -REAL, DIMENSION(:,:,:), INTENT(IN) :: PMZM_RHODJ - ! metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT , PRVCT, PRWCT - ! Contravariant wind components -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUS_ADV , PRVS_ADV, PRWS_ADV - ! Tendency due to advection -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUS_OTHER , PRVS_OTHER, PRWS_OTHER -! ! tendencies from other processes -! -!* 0.2 declarations of local variables -! -character(len=3) :: ynum -INTEGER :: IKE ! indice K End in z direction -! -#ifndef MNH_OPENACC -REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZUT, ZVT, ZWT -! Intermediate Guesses inside the RK loop -! -REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZRUS, ZRVS, ZRWS, ZIBM -! Momentum tendencies due to advection -REAL, DIMENSION(:,:), ALLOCATABLE :: ZBUT ! Butcher array coefficients - ! at the RK sub time step -REAL, DIMENSION(:), ALLOCATABLE :: ZBUTS! Butcher array coefficients - ! at the end of the RK loop -#else -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZUT, ZVT, ZWT -! Intermediate Guesses inside the RK loop -! -REAL, DIMENSION(:,:,:,:), POINTER, CONTIGUOUS :: ZRUS, ZRVS, ZRWS, ZIBM -! Momentum tendencies due to advection -REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZBUT ! Butcher array coefficients - ! at the RK sub time step -REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZBUTS! Butcher array coefficients - ! at the end of the RK loop -#endif -!JUAN -TYPE(LIST_ll), POINTER :: TZFIELDMT_ll ! list of fields to exchange -TYPE(HALO2LIST_ll), POINTER :: TZHALO2MT_ll ! momentum variables -#ifdef MNH_OPENACC -TYPE(HALO2LIST_ll), SAVE , POINTER :: TZHALO2_UT,TZHALO2_VT,TZHALO2_WT -LOGICAL , SAVE :: GFIRST_CALL_ADVECUVW_RK = .TRUE. -#endif -INTEGER :: INBVAR -INTEGER :: IIU, IJU, IKU ! array sizes -!JUAN - -! Momentum tendencies due to advection -INTEGER :: ISPL ! Number of RK splitting loops -INTEGER :: JI, JS ! Loop index -! -INTEGER :: IINFO_ll ! return code of parallel routine -TYPE(LIST_ll), POINTER :: TZFIELD_ll ! list of fields to exchange -TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange -TYPE(LIST_ll), POINTER :: TZFIELDS0_ll ! list of fields to exchange -TYPE(LIST_ll), POINTER :: TZFIELDS4_ll ! list of fields to exchange -! -LOGICAL :: GIBM !Intermediate variable used to work around a Cray compiler bug (CCE 13.0.0) -REAL :: ZIBM_EPSI !Intermediate variable used to work around a Cray compiler bug (CCE 13.0.0) -REAL :: ZTIME1,ZTIME2 -CHARACTER(LEN=6) :: CIBM_ADV -LOGICAL :: GIBM_FREEZE,GIBM_LOWORD,GIBM_FORCIN -INTEGER :: JII,JJI,JKI -!------------------------------------------------------------------------------- - - -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PU,"ADVECUVW_RK beg:PU") - CALL MPPDB_CHECK(PV,"ADVECUVW_RK beg:PV") - CALL MPPDB_CHECK(PW,"ADVECUVW_RK beg:PW") - CALL MPPDB_CHECK(PUT,"ADVECUVW_RK beg:PUT") - CALL MPPDB_CHECK(PVT,"ADVECUVW_RK beg:PVT") - CALL MPPDB_CHECK(PWT,"ADVECUVW_RK beg:PWT") - CALL MPPDB_CHECK(PMXM_RHODJ,"ADVECUVW_RK beg:PMXM_RHODJ") - CALL MPPDB_CHECK(PMYM_RHODJ,"ADVECUVW_RK beg:PMYM_RHODJ") - CALL MPPDB_CHECK(PMZM_RHODJ,"ADVECUVW_RK beg:PMZM_RHODJ") - CALL MPPDB_CHECK(PRUCT,"ADVECUVW_RK beg:PRUCT") - CALL MPPDB_CHECK(PRVCT,"ADVECUVW_RK beg:PRVCT") - CALL MPPDB_CHECK(PRWCT,"ADVECUVW_RK beg:PRWCT") - CALL MPPDB_CHECK(PRUS_OTHER,"ADVECUVW_RK beg:PRUS_OTHER") - CALL MPPDB_CHECK(PRVS_OTHER,"ADVECUVW_RK beg:PRVS_OTHER") - CALL MPPDB_CHECK(PRWS_OTHER,"ADVECUVW_RK beg:PRWS_OTHER") -END IF - -GIBM = LIBM -ZIBM_EPSI = XIBM_EPSI -CIBM_ADV = MODD_CIBM_ADV - -GIBM_FREEZE = ( GIBM .AND. CIBM_ADV=='FREEZE' ) -GIBM_LOWORD = ( GIBM .AND. CIBM_ADV=='LOWORD' ) -GIBM_FORCIN = ( GIBM .AND. CIBM_ADV=='FORCIN' ) - -#ifdef MNH_OPENACC -if ( GIBM ) call Print_msg( NVERB_FATAL, 'GEN', 'ADVECUVW_RK', 'OpenACC: LIBM=T not yet implemented' ) -#endif -! -!* 0. INITIALIZATION -! --------------------- -! -IKE = SIZE(PWT,3) - JPVEXT -IIU=SIZE(PUT,1) -IJU=SIZE(PUT,2) -IKU=SIZE(PUT,3) -! -SELECT CASE (HTEMP_SCHEME) - CASE('RK11') - ISPL = 1 - CASE('RK21') - ISPL = 2 - CASE('NP32') - ISPL = 3 - CASE('SP32') - ISPL = 3 - CASE('RK33') - ISPL = 3 - CASE('RKC4') - ISPL = 4 - CASE('RK4B') - ISPL = 4 - CASE('RK53') - ISPL = 5 - CASE('RK62') - ISPL = 6 - CASE('RK65') - ISPL = 6 - CASE DEFAULT - call Print_msg(NVERB_FATAL,'GEN','ADVECUVW_RK','unknown HTEMP_SCHEME') -END SELECT -! -#ifndef MNH_OPENACC -allocate( ZUT(IIU, IJU, IKU) ) -allocate( ZVT(IIU, IJU, IKU) ) -allocate( ZWT(IIU, IJU, IKU) ) - -ALLOCATE( ZRUS(IIU, IJU, IKU, ISPL) ) -ALLOCATE( ZRVS(IIU, IJU, IKU, ISPL) ) -ALLOCATE( ZRWS(IIU, IJU, IKU, ISPL) ) - -IF ( GIBM ) ALLOCATE( ZIBM(IIU, IJU, IKU, 3) ) - -ALLOCATE(ZBUT(ISPL-1,ISPL-1)) -ALLOCATE(ZBUTS(ISPL)) -#else -!Pin positions in the pools of MNH memory -CALL MNH_MEM_POSITION_PIN() - -CALL MNH_MEM_GET( ZUT, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZVT, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZWT, IIU, IJU, IKU ) - -CALL MNH_MEM_GET( ZRUS, IIU, IJU, IKU, ISPL ) -CALL MNH_MEM_GET( ZRVS, IIU, IJU, IKU, ISPL ) -CALL MNH_MEM_GET( ZRWS, IIU, IJU, IKU, ISPL ) - -IF ( GIBM ) CALL MNH_MEM_GET( ZIBM, IIU, IJU, IKU, 3 ) - -CALL MNH_MEM_GET( ZBUT, ISPL-1, ISPL-1 ) -CALL MNH_MEM_GET( ZBUTS, ISPL ) -#endif - -#ifdef MNH_OPENACC -CALL INIT_ON_HOST_AND_DEVICE(ZUT,4e99,'ADVECUVW_RK::ZUT') -CALL INIT_ON_HOST_AND_DEVICE(ZVT,5e99,'ADVECUVW_RK::ZVT') -CALL INIT_ON_HOST_AND_DEVICE(ZWT,6e99,'ADVECUVW_RK::ZWT') -#endif - -!$acc data present( PU, PV, PW, PUT, PVT, PWT, PMXM_RHODJ, PMYM_RHODJ, PMZM_RHODJ, & -!$acc & PRUCT, PRVCT, PRWCT, PRUS_ADV, PRVS_ADV, PRWS_ADV, & -!$acc & PRUS_OTHER, PRVS_OTHER, PRWS_OTHER, ZUT, ZVT, ZWT, & -!$acc & ZRUS, ZRVS, ZRWS, ZBUT, ZBUTS ) - -SELECT CASE (HTEMP_SCHEME) - CASE('RK11') - ZBUTS = (/ 1. /) - CASE('RK21') - ZBUTS = (/ 0. , 1. /) - ZBUT(1,1) = 3./4. - CASE('RK33') - ZBUTS = (/ 1./6. , 1./6. , 2./3. /) - ZBUT(1,1) = 1. - ZBUT(1,2) = 0. - ZBUT(2,1) = 1./4. - ZBUT(2,2) = 1./4. - CASE('NP32') - ZBUTS = (/ 1./2. , 0., 1./2. /) - ZBUT(1,1) = 1./3. - ZBUT(1,2) = 0. - ZBUT(2,1) = 0. - ZBUT(2,2) = 1. - CASE('SP32') - ZBUTS = (/ 1./3. , 1./3. , 1./3. /) - ZBUT(1,1) = 1./2. - ZBUT(1,2) = 0. - ZBUT(2,1) = 1./2. - ZBUT(2,2) = 1./2. - CASE('RKC4') - ZBUTS = (/ 1./6. , 1./3. , 1./3. , 1./6./) - ZBUT = 0. - ZBUT(1,1) = 1./2. - ZBUT(2,2) = 1./2. - ZBUT(3,3) = 1. - CASE('RK4B') - ZBUTS = (/ 1./8. , 3./8. , 3./8. , 1./8./) - ZBUT = 0. - ZBUT(1,1) = 1./3. - ZBUT(2,1) = -1./3. - ZBUT(2,2) = 1. - ZBUT(3,1) = 1. - ZBUT(3,2) = -1. - ZBUT(3,3) = 1. - CASE('RK53') - ZBUTS = (/ 1./4. , 0. , 0. , 0. , 3./4. /) - ZBUT = 0. - ZBUT(1,1) = 1./7. - ZBUT(2,2) = 3./16. - ZBUT(3,3) = 1./3. - ZBUT(4,4) = 2./3. - CASE('RK62') - ZBUTS = (/ 1./6. , 1./6. , 1./6. , 1./6. , 1./6. , 1./6. /) - ZBUT = 0. - ZBUT(1,1) = 1./5. - ZBUT(2,1) = 1./5. - ZBUT(2,2) = 1./5. - ZBUT(3,1) = 1./5. - ZBUT(3,2) = 1./5. - ZBUT(3,3) = 1./5. - ZBUT(4,1) = 1./5. - ZBUT(4,2) = 1./5. - ZBUT(4,3) = 1./5. - ZBUT(4,4) = 1./5. - ZBUT(5,1) = 1./5. - ZBUT(5,2) = 1./5. - ZBUT(5,3) = 1./5. - ZBUT(5,4) = 1./5. - ZBUT(5,5) = 1./5. -CASE('RK65') - ZBUTS= (/ 7./90. , 0. , 16./45. , 2./15. , 16./45. , 7./90. /) - ZBUT= 0. - ZBUT(1,1) = 1./4. - ZBUT(2,1) = 1./8. - ZBUT(2,2) = 1./8. - ZBUT(3,1) = 0 - ZBUT(3,2) = -1./2. - ZBUT(3,3) = 1 - ZBUT(4,1) = 3./16. - ZBUT(4,2) = 0 - ZBUT(4,3) = 0 - ZBUT(4,4) = 9./16. - ZBUT(5,1) = -3./7. - ZBUT(5,2) = 2./7. - ZBUT(5,3) = 12./7. - ZBUT(5,4) = -12./7. - ZBUT(5,5) = 8./7. -END SELECT -!$acc update device(ZBUTS,ZBUT) -! -IF ( GIBM ) THEN -!$acc kernels present(ZIBM) - ZIBM(:,:,:,:) = 1. -!$acc end kernels -END IF -! -IF (GIBM_FREEZE) THEN -!$acc kernels present(ZIBM) - WHERE (XIBM_LS(:,:,:,2).GT.-ZIBM_EPSI) ZIBM(:,:,:,1) = 0. - WHERE (XIBM_LS(:,:,:,3).GT.-ZIBM_EPSI) ZIBM(:,:,:,2) = 0. - WHERE (XIBM_LS(:,:,:,4).GT.-ZIBM_EPSI) ZIBM(:,:,:,3) = 0. -!$acc end kernels -ENDIF -! -!$acc kernels present(PRUS_ADV,PRVS_ADV,PRWS_ADV) present(ZUT,ZVT,ZWT) present(PU,PV,PW) -PRUS_ADV(:,:,:) = 0. -PRVS_ADV(:,:,:) = 0. -PRWS_ADV(:,:,:) = 0. -! -!------------------------------------------------------------------------------- -! -!* 2. Wind guess before RK loop -! -------------------------------- -! -ZUT(:,:,:) = PU(:,:,:) -ZVT(:,:,:) = PV(:,:,:) -ZWT(:,:,:) = PW(:,:,:) -!$acc end kernels -! -#ifndef MNH_OPENACC -CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZUT, PUT, 'U' ) -CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZVT, PVT, 'V' ) -CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZWT, PWT, 'W' ) -#else -CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZUT, PUT, 'U' ) -CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZVT, PVT, 'V' ) -CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZWT, PWT, 'W' ) -#endif -! -NULLIFY(TZFIELDMT_ll) -CALL ADD3DFIELD_ll( TZFIELDMT_ll, ZUT, 'ADVECUVW_RK::ZUT' ) -CALL ADD3DFIELD_ll( TZFIELDMT_ll, ZVT, 'ADVECUVW_RK::ZVT' ) -CALL ADD3DFIELD_ll( TZFIELDMT_ll, ZWT, 'ADVECUVW_RK::ZWT' ) -INBVAR = 3 -#ifndef MNH_OPENACC -CALL INIT_HALO2_ll(TZHALO2MT_ll,INBVAR,SIZE(PUT,1),SIZE(PUT,2),SIZE(PWT,3)) -#endif -! -!$acc kernels present_cr(ZRUS,ZRVS,ZRWS) -ZRUS(:, :, :, : ) = 0. -ZRVS(:, :, :, : ) = 0. -ZRWS(:, :, :, : ) = 0. -!$acc end kernels - -!------------------------------------------------------------------------------- -! -!* 3. BEGINNING of Runge-Kutta loop -! ------------------------------------ -! -RKLOOP: DO JS = 1, ISPL -! -#ifndef MNH_OPENACC - CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZUT, PUT, 'U' ) - CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZVT, PVT, 'V' ) - CALL ADV_BOUNDARIES (HLBCX, HLBCY, ZWT, PWT, 'W' ) -#else - CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZUT, PUT, 'U' ) - CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZVT, PVT, 'V' ) - CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZWT, PWT, 'W' ) -#endif - ! -#ifndef MNH_OPENACC - CALL UPDATE_HALO_ll(TZFIELDMT_ll,IINFO_ll) - CALL UPDATE_HALO2_ll(TZFIELDMT_ll, TZHALO2MT_ll, IINFO_ll) -#else - IF (GFIRST_CALL_ADVECUVW_RK) THEN - GFIRST_CALL_ADVECUVW_RK = .FALSE. - NULLIFY(TZHALO2_UT,TZHALO2_VT,TZHALO2_WT) - CALL INIT_HALO2_ll(TZHALO2_UT,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_VT,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_WT,1,IIU,IJU,IKU) - END IF - - CALL GET_HALO2_DF(ZUT,TZHALO2_UT,HNAME='ZUT') - CALL GET_HALO2_DF(ZVT,TZHALO2_VT,HNAME='ZVT') - CALL GET_HALO2_DF(ZWT,TZHALO2_WT,HNAME='ZWT') -#endif -! -!* 4. Advection with WENO -! -------------------------- -! -IF (GIBM_LOWORD) THEN -!$acc kernels present(ZIBM) - ZIBM(:,:,:,1)=ZRUS(:,:,:,JS) - ZIBM(:,:,:,2)=ZRVS(:,:,:,JS) - ZIBM(:,:,:,3)=ZRWS(:,:,:,JS) -!$acc end kernels -ENDIF -! -!!$TZHALO2_UT => TZHALO2MT_ll ! 1rst add3dfield in model_n -!!$TZHALO2_VT => TZHALO2MT_ll%NEXT ! 2nd add3dfield in model_n -!!$TZHALO2_WT => TZHALO2MT_ll%NEXT%NEXT ! 3rst add3dfield in model_n - - IF (HUVW_ADV_SCHEME=='WENO_K') THEN - CALL ADVECUVW_WENO_K (HLBCX, HLBCY, KWENO_ORDER, ZUT, ZVT, ZWT, & - PRUCT, PRVCT, PRWCT, & - ZRUS(:,:,:,JS), ZRVS(:,:,:,JS), ZRWS(:,:,:,JS), & -#ifndef MNH_OPENACC - TZHALO2MT_ll ) -#else - TZHALO2_UT,TZHALO2_VT,TZHALO2_WT ) -#endif - ELSE IF ((HUVW_ADV_SCHEME=='CEN4TH') .AND. (HTEMP_SCHEME=='RKC4')) THEN -#ifdef MNH_OPENACC - !STOP "HUVW_ADV_SCHEME=='CEN4TH') .AND. (HTEMP_SCHEME=='RKC4') NOT TESTED WITH OPENACC" -#endif - CALL ADVECUVW_4TH (HLBCX, HLBCY, PRUCT, PRVCT, PRWCT, & - ZUT, ZVT, ZWT, & - ZRUS(:,:,:,JS), ZRVS(:,:,:,JS), ZRWS(:,:,:,JS), & -#ifndef MNH_OPENACC - TZHALO2MT_ll ) -#else - TZHALO2_UT,TZHALO2_VT,TZHALO2_WT ) -#endif - ENDIF -! - IF (GIBM_LOWORD) THEN - IF (HUVW_ADV_SCHEME=='WENO_K') THEN - CALL ADVECUVW_WENO_K (HLBCX, HLBCY, 3, ZUT, ZVT, ZWT, & - PRUCT, PRVCT, PRWCT, & - ZIBM(:,:,:,1), ZIBM(:,:,:,2), ZIBM(:,:,:,3) ,& -#ifndef MNH_OPENACC - TZHALO2MT_ll ) -#else - TZHALO2_UT,TZHALO2_VT,TZHALO2_WT ) -#endif - ENDIF - IF (HUVW_ADV_SCHEME=='CEN4TH') THEN - CALL ADVECUVW_2ND (ZUT, ZVT, ZWT, PRUCT, PRVCT, PRWCT, & - ZIBM(:,:,:,1), ZIBM(:,:,:,2), ZIBM(:,:,:,3)) - ENDIF -! JE: Memory Leak with nvhpc22.2 with WHERE , even when GIBM FALSE /!\ -> replace DO CONCURRENT - DO CONCURRENT ( JII=1:IIU , JJI=1:IJU , JKI=1:IKU ) - IF (XIBM_LS(JII,JJI,JKI,2).GT.-ZIBM_EPSI) THEN - ZRUS(JII,JJI,JKI,JS)=ZIBM(JII,JJI,JKI,1) - END IF - IF (XIBM_LS(JII,JJI,JKI,3).GT.-ZIBM_EPSI) THEN - ZRVS(JII,JJI,JKI,JS)=ZIBM(JII,JJI,JKI,2) - END IF - IF (XIBM_LS(JII,JJI,JKI,4).GT.-ZIBM_EPSI) THEN - ZRWS(JII,JJI,JKI,JS)=ZIBM(JII,JJI,JKI,3) - END IF - END DO - ZIBM(:,:,:,:)=1. - ENDIF -! - write ( ynum, '( I3 )' ) js -#ifndef MNH_OPENACC - NULLIFY(TZFIELDS4_ll) - CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRUS(:,:,:,JS), 'ADVECUVW_RK::ZRUS(:,:,:,'//trim( adjustl( ynum ) )//')' ) - CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRVS(:,:,:,JS), 'ADVECUVW_RK::ZRVS(:,:,:,'//trim( adjustl( ynum ) )//')' ) - CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRWS(:,:,:,JS), 'ADVECUVW_RK::ZRWS(:,:,:,'//trim( adjustl( ynum ) )//')' ) - CALL UPDATE_HALO_ll(TZFIELDS4_ll,IINFO_ll) - CALL CLEANLIST_ll(TZFIELDS4_ll) -#else - CALL GET_HALO_D(ZRUS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRUS(:,:,:,'//trim( adjustl( ynum ) )//')' ) - CALL GET_HALO_D(ZRVS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRVS(:,:,:,'//trim( adjustl( ynum ) )//')' ) - CALL GET_HALO_D(ZRWS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRWS(:,:,:,'//trim( adjustl( ynum ) )//')' ) -! acc update device(ZRUS(:,:,:,JS),ZRVS(:,:,:,JS),ZRWS(:,:,:,JS)) -#endif -! - IF (GIBM_FREEZE) THEN - ! JE: Memory Leak with nvhpc22.2 with WHERE , even when GIBM FALSE /!\ -> replace DO CONCURRENT - DO CONCURRENT ( JII=1:IIU , JJI=1:IJU , JKI=1:IKU ) - IF (XIBM_LS(JII,JJI,JKI,2).GT.-ZIBM_EPSI) THEN - ZRUS(JII,JJI,JKI,JS)=ZUT(JII,JJI,JKI)*PMXM_RHODJ(JII,JJI,JKI)/PTSTEP - END IF - IF (XIBM_LS(JII,JJI,JKI,3).GT.-ZIBM_EPSI) THEN - ZRVS(JII,JJI,JKI,JS)=ZVT(JII,JJI,JKI)*PMYM_RHODJ(JII,JJI,JKI)/PTSTEP - END IF - IF (XIBM_LS(JII,JJI,JKI,4).GT.-ZIBM_EPSI) THEN - ZRWS(JII,JJI,JKI,JS)=ZWT(JII,JJI,JKI)*PMZM_RHODJ(JII,JJI,JKI)/PTSTEP - END IF - END DO - ENDIF - - IF (GIBM_FORCIN) THEN - CALL SECOND_MNH(ZTIME1) - CALL IBM_FORCING_ADV(ZRUS(:,:,:,JS),ZRVS(:,:,:,JS),ZRWS(:,:,:,JS)) - CALL SECOND_MNH(ZTIME2) - XT_IBM_FORC = XT_IBM_FORC + ZTIME2 - ZTIME1 - ENDIF -! -! Guesses at the end of the RK loop -! - - IF ( .NOT. GIBM ) THEN -!$acc kernels present(PRUS_ADV,PRVS_ADV,PRWS_ADV,ZBUTS) present(ZRUS,ZRVS,ZRWS) - PRUS_ADV(:,:,:) = PRUS_ADV(:,:,:) + ZBUTS(JS) * ZRUS(:,:,:,JS) - PRVS_ADV(:,:,:) = PRVS_ADV(:,:,:) + ZBUTS(JS) * ZRVS(:,:,:,JS) - PRWS_ADV(:,:,:) = PRWS_ADV(:,:,:) + ZBUTS(JS) * ZRWS(:,:,:,JS) -!$acc end kernels - ELSE -!$acc kernels present(PRUS_ADV,PRVS_ADV,PRWS_ADV,ZBUTS) present(ZRUS,ZRVS,ZRWS,ZIBM) - PRUS_ADV(:,:,:) = PRUS_ADV(:,:,:) + ZBUTS(JS) * ZRUS(:,:,:,JS) * ZIBM(:,:,:,1) - PRVS_ADV(:,:,:) = PRVS_ADV(:,:,:) + ZBUTS(JS) * ZRVS(:,:,:,JS) * ZIBM(:,:,:,2) - PRWS_ADV(:,:,:) = PRWS_ADV(:,:,:) + ZBUTS(JS) * ZRWS(:,:,:,JS) * ZIBM(:,:,:,3) -!$acc end kernels - END IF - -! - IF ( JS < ISPL ) THEN -!PW: note: 20211025: kernels split because performance problems if in 1 block with NVHPC 21.9 -! !$acc kernels present(ZUT,ZVT,ZWT) present(ZBUT) present(PU,PV,PW) & -! !$acc & present(ZRUS,ZRVS,ZRWS,ZIBM) present(PRUS_OTHER,PRVS_OTHER,PRWS_OTHER) & -! !$acc & present(PMXM_RHODJ,PMYM_RHODJ,PMZM_RHODJ) -! -!$acc kernels present( ZUT, ZVT, ZWT ) - ZUT(:,:,:) = PU(:,:,:) - ZVT(:,:,:) = PV(:,:,:) - ZWT(:,:,:) = PW(:,:,:) -!$acc end kernels -! - DO JI = 1, JS -! -! Intermediate guesses inside the RK loop -! - IF ( .NOT. GIBM ) THEN -!$acc kernels present( ZUT, ZVT, ZWT, ZRUS, ZRVS, ZRWS ) - ZUT(:,:,:) = ZUT(:,:,:) + ZBUT(JS,JI) * PTSTEP * & - ( ZRUS(:,:,:,JI) + PRUS_OTHER(:,:,:) ) / PMXM_RHODJ(:,:,:) - ZVT(:,:,:) = ZVT(:,:,:) + ZBUT(JS,JI) * PTSTEP * & - ( ZRVS(:,:,:,JI) + PRVS_OTHER(:,:,:) ) / PMYM_RHODJ(:,:,:) - ZWT(:,:,:) = ZWT(:,:,:) + ZBUT(JS,JI) * PTSTEP * & - ( ZRWS(:,:,:,JI) + PRWS_OTHER(:,:,:) ) / PMZM_RHODJ(:,:,:) -!$acc end kernels - ELSE -!$acc kernels present( ZUT, ZVT, ZWT, ZRUS, ZRVS, ZRWS, ZIBM ) - ZUT(:,:,:) = ZUT(:,:,:) + ZBUT(JS,JI) * PTSTEP * & - ( ZRUS(:,:,:,JI) + PRUS_OTHER(:,:,:) ) / PMXM_RHODJ(:,:,:) * ZIBM(:,:,:,1) - ZVT(:,:,:) = ZVT(:,:,:) + ZBUT(JS,JI) * PTSTEP * & - ( ZRVS(:,:,:,JI) + PRVS_OTHER(:,:,:) ) / PMYM_RHODJ(:,:,:) * ZIBM(:,:,:,2) - ZWT(:,:,:) = ZWT(:,:,:) + ZBUT(JS,JI) * PTSTEP * & - ( ZRWS(:,:,:,JI) + PRWS_OTHER(:,:,:) ) / PMZM_RHODJ(:,:,:) * ZIBM(:,:,:,3) -!$acc end kernels - END IF -! - END DO -! !$acc end kernels -! acc update self(ZUT,ZVT,ZWT) - END IF -! -! End of the RK loop - END DO RKLOOP -! -! -CALL CLEANLIST_ll(TZFIELDMT_ll) -#ifndef MNH_OPENACC -CALL DEL_HALO2_ll(TZHALO2MT_ll) -#endif -!!!!!!!!!!$acc update self(PRUS_ADV,PRVS_ADV,PRWS_ADV) -!------------------------------------------------------------------------------- - -!$acc end data - -#ifdef MNH_OPENACC -!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN -CALL MNH_MEM_RELEASE() -#endif - -IF (MPPDB_INITIALIZED) THEN - !Check all OUT arrays - CALL MPPDB_CHECK(PRUS_ADV,"ADVECUVW_RK end:PRUS_ADV") - CALL MPPDB_CHECK(PRVS_ADV,"ADVECUVW_RK end:PRVS_ADV") - CALL MPPDB_CHECK(PRWS_ADV,"ADVECUVW_RK end:PRWS_ADV") -END IF - -END SUBROUTINE ADVECUVW_RK diff --git a/src/ZSOLVER/advecuvw_weno_k.f90 b/src/ZSOLVER/advecuvw_weno_k.f90 deleted file mode 100644 index d4c5ed972ad705a4477f8e9f1e5f1f4233c50e1f..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/advecuvw_weno_k.f90 +++ /dev/null @@ -1,715 +0,0 @@ -!MNH_LIC Copyright 2013-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! ########################### - MODULE MODI_ADVECUVW_WENO_K -! ########################### -! -INTERFACE -! - SUBROUTINE ADVECUVW_WENO_K(HLBCX, HLBCY, KWENO_ORDER, PUT, PVT, PWT, & - PRUCT, PRVCT, PRWCT, PRUS, PRVS, PRWS, & -#ifndef MNH_OPENACC - TPHALO2LIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! -USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO - ! scheme (3 or 5) -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT ! contravariant -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVCT ! components -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWCT ! of momentum -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT, PWT ! U,V,W at t -! -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS ! Source terms -! -#ifndef MNH_OPENACC -TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list for diffusion -#else -TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT -#endif -! -! -END SUBROUTINE ADVECUVW_WENO_K -! -END INTERFACE -! -END MODULE MODI_ADVECUVW_WENO_K -! -! ########################################################################## - SUBROUTINE ADVECUVW_WENO_K(HLBCX, HLBCY, KWENO_ORDER, PUT, PVT, PWT, & - PRUCT, PRVCT, PRWCT, PRUS, PRVS, PRWS, & -#ifndef MNH_OPENACC - TPHALO2LIST ) -#else - TPHALO2_UT,TPHALO2_VT,TPHALO2_WT ) -#endif -! ########################################################################## -! -!! AUTHOR -!! ------ -!! -!! -!! MODIFICATIONS -!! ------------- -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 tests -!! T.Lunet 02/10/2014: add get_halo for WENO 5 -!! suppress comment of NHALO=1 tests -!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 -!! -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -USE MODD_CONF, ONLY : L2D, NHALO -USE MODD_PARAMETERS - -USE MODE_ll -#ifdef MNH_OPENACC -USE MODE_DEVICE -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -#endif -USE MODE_MPPDB - -USE MODI_ADVEC_WENO_K_1_AUX -USE MODI_ADVEC_WENO_K_2_AUX -USE MODI_ADVEC_WENO_K_3_AUX -USE MODI_GET_HALO -#ifndef MNH_OPENACC -USE MODI_SHUMAN -#else -USE MODI_SHUMAN_DEVICE -#endif - -IMPLICIT NONE -! -!* 0.1 Declarations of dummy arguments : -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -INTEGER, INTENT(IN) :: KWENO_ORDER ! Order of the WENO - ! scheme (3 or 5) -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUCT ! contravariant -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVCT ! components -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWCT ! of momentum -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PUT, PVT, PWT ! Variables at t -! -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS, PRVS, PRWS ! Source terms -! -#ifndef MNH_OPENACC -TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list for diffusion -#else -TYPE(HALO2LIST_ll), POINTER :: TPHALO2_UT,TPHALO2_VT,TPHALO2_WT -#endif -! -!* 0.2 Declarations of local variables : -! -INTEGER :: IIU, IJU, IKU -TYPE(HALO2LIST_ll), POINTER :: TZHALO2_UT,TZHALO2_VT,TZHALO2_WT -INTEGER :: IINFO_ll ! return code of parallel routine -! -#ifndef MNH_OPENACC -REAL, DIMENSION(:,:,:), allocatable :: ZMEAN, ZWORK -#else -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZMEAN, ZWORK -! -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZFPOS1, ZFPOS2, ZFPOS3 -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZFNEG1, ZFNEG2, ZFNEG3 -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZBPOS1, ZBPOS2, ZBPOS3 -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZBNEG1, ZBNEG2, ZBNEG3 -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZOMP1, ZOMP2, ZOMP3 -REAL, DIMENSION(:,:,:), POINTER ,CONTIGUOUS :: ZOMN1, ZOMN2, ZOMN3 -#endif -! -! -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PRUCT,"ADVECUVW_WENO_K beg:PRUCT") - CALL MPPDB_CHECK(PRVCT,"ADVECUVW_WENO_K beg:PRVCT") - CALL MPPDB_CHECK(PRWCT,"ADVECUVW_WENO_K beg:PRWCT") - CALL MPPDB_CHECK(PUT,"ADVECUVW_WENO_K beg:PUT") - CALL MPPDB_CHECK(PVT,"ADVECUVW_WENO_K beg:PVT") - CALL MPPDB_CHECK(PWT,"ADVECUVW_WENO_K beg:PWT") - !Check all INOUT arrays - CALL MPPDB_CHECK(PRUS,"ADVECUVW_WENO_K beg:PRUS") - CALL MPPDB_CHECK(PRVS,"ADVECUVW_WENO_K beg:PRVS") - CALL MPPDB_CHECK(PRWS,"ADVECUVW_WENO_K beg:PRWS") -END IF - -IIU = SIZE( PUT, 1 ) -IJU = SIZE( PUT, 2 ) -IKU = SIZE( PUT, 3 ) - -#ifndef MNH_OPENACC -allocate( ZMEAN(IIU, IJU, IKU) ) -allocate( ZWORK(IIU, IJU, IKU) ) -#else -!Pin positions in the pools of MNH memory -CALL MNH_MEM_POSITION_PIN() - -CALL MNH_MEM_GET( ZMEAN, IIU, IJU, IKU ) -CALL MNH_MEM_GET( ZWORK, IIU, IJU, IKU ) -#endif - -#ifdef MNH_OPENACC -CALL INIT_ON_HOST_AND_DEVICE(ZMEAN,1e90,'ADVECUVW_WENO_K::ZMEAN') -CALL INIT_ON_HOST_AND_DEVICE(ZWORK,2e90,'ADVECUVW_WENO_K::ZWORK') -#endif -! -!------------------------- ADVECTION OF MOMENTUM ------------------------------ -! -! -#ifndef MNH_OPENACC -TZHALO2_UT => TPHALO2LIST ! 1rst add3dfield in model_n -TZHALO2_VT => TPHALO2LIST%NEXT ! 2nd add3dfield in model_n -TZHALO2_WT => TPHALO2LIST%NEXT%NEXT ! 3rst add3dfield in model_n -#else -TZHALO2_UT => TPHALO2_UT -TZHALO2_VT => TPHALO2_VT -TZHALO2_WT => TPHALO2_WT -#endif -! -! ------------------------------------------------------- - -!$acc data present( PRUCT, PRVCT, PRWCT, PUT, PVT, PWT, PRUS, PRVS, PRWS, ZMEAN, ZWORK ) - -SELECT CASE(KWENO_ORDER) -! -CASE(1) ! WENO 1 -#ifndef MNH_OPENACC -! -! U component -! - PRUS = PRUS - DXM(UP_UX(PUT,MXF(PRUCT))) -! - PRUS = PRUS - DYF(UP_MY(PUT,MXM(PRVCT))) -! - PRUS = PRUS - DZF(UP_MZ(PUT,MXM(PRWCT))) -! -! V component -! - PRVS = PRVS - DXF(UP_MX(PVT,MYM(PRUCT))) -! - PRVS = PRVS - DYM(UP_VY(PVT,MYF(PRVCT))) -! - PRVS = PRVS - DZF(UP_MZ(PVT,MYM(PRWCT))) -! -! W component -! - PRWS = PRWS - DXF(UP_MX(PWT,MZM(PRUCT))) -! - PRWS = PRWS - DYF(UP_MY(PWT,MZM(PRVCT))) -! - PRWS = PRWS - DZM(UP_WZ(PWT,MZF(PRWCT))) -#else -! -! U component -! - !PRUS = PRUS - DXM(UP_UX(PUT,MXF(PRUCT))) - CALL MXF_DEVICE(PRUCT,ZWORK) - CALL UP_UX_DEVICE(PUT,ZWORK,ZMEAN) - CALL DXM_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !PRUS = PRUS - DYF(UP_MY(PUT,MXM(PRVCT))) - CALL MXM_DEVICE(PRVCT,ZWORK) - CALL UP_MY_DEVICE(PUT,ZWORK,ZMEAN) - CALL DYF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !PRUS = PRUS - DZF(UP_MZ(PUT,MXM(PRWCT))) - CALL MXM_DEVICE(PRWCT,ZWORK) - CALL UP_MZ_DEVICE(PUT,ZWORK,ZMEAN) - CALL DZF_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! -! V component -! - !PRVS = PRVS - DXF(UP_MX(PVT,MYM(PRUCT))) - CALL MYM_DEVICE(PRUCT,ZWORK) - CALL UP_MX_DEVICE(PVT,ZWORK,ZMEAN) - CALL DXF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !PRVS = PRVS - DYM(UP_VY(PVT,MYF(PRVCT))) - CALL MYF_DEVICE(PRVCT,ZWORK) - CALL UP_VY_DEVICE(PVT,ZWORK,ZMEAN) - CALL DYM_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !PRVS = PRVS - DZF( UP_MZ(PVT,MYM(PRWCT))) - CALL MYM_DEVICE(PRWCT,ZWORK) - CALL UP_MZ_DEVICE(PVT,ZWORK,ZMEAN) - CALL DZF_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! -! W component -! - !PRWS = PRWS - DXF(UP_MX(PWT,MZM(PRUCT))) - CALL MZM_DEVICE(PRUCT,ZWORK) - CALL UP_MX_DEVICE(PWT,ZWORK,ZMEAN) - CALL DXF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !PRWS = PRWS - DYF(UP_MY(PWT,MZM(PRVCT))) - CALL MZM_DEVICE(PRVCT,ZWORK) - CALL UP_MY_DEVICE(PWT,ZWORK,ZMEAN) - CALL DYF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !PRWS = PRWS - DZM(UP_WZ(PWT,MZF(PRWCT))) - CALL MZF_DEVICE( PRWCT, ZWORK ) - CALL UP_WZ_DEVICE(PWT,ZWORK,ZMEAN) - CALL DZM_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -#endif -! -! -CASE(3) ! WENO 3 -#ifndef MNH_OPENACC -! -! U component -! - ZWORK = MXF(PRUCT) - CALL ADVEC_WENO_K_2_UX(HLBCX, PUT, ZWORK, ZMEAN, TZHALO2_UT%HALO2) - PRUS = PRUS - DXM(ZMEAN) - -! - IF (.NOT.L2D) THEN - ZWORK = MXM(PRVCT) - CALL ADVEC_WENO_K_2_MY(HLBCY, PUT, ZWORK, ZMEAN, TZHALO2_UT%HALO2) - PRUS = PRUS - DYF(ZMEAN) - END IF -! - PRUS = PRUS - DZF(WENO_K_2_MZ(PUT, MXM(PRWCT))) -! -! V component -! - IF (.NOT.L2D) THEN - ZWORK = MYM(PRUCT) - CALL ADVEC_WENO_K_2_MX(HLBCX, PVT, ZWORK, ZMEAN, TZHALO2_VT%HALO2) - PRVS = PRVS - DXF(ZMEAN) -! - ZWORK = MYF(PRVCT) - CALL ADVEC_WENO_K_2_VY(HLBCY, PVT, ZWORK, ZMEAN, TZHALO2_VT%HALO2) - PRVS = PRVS - DYM(ZMEAN) -! - PRVS = PRVS - DZF(WENO_K_2_MZ(PVT, MYM(PRWCT))) - END IF -! -! W component -! - ZWORK = MZM(PRUCT) - CALL ADVEC_WENO_K_2_MX(HLBCX, PWT, ZWORK, ZMEAN, TZHALO2_WT%HALO2) - PRWS = PRWS - DXF(ZMEAN) -! - IF (.NOT.L2D) THEN - ZWORK = MZM(PRVCT) - CALL ADVEC_WENO_K_2_MY(HLBCY, PWT, ZWORK, ZMEAN, TZHALO2_WT%HALO2) - PRWS = PRWS - DYF(ZMEAN) - END IF -! - PRWS = PRWS - DZM(WENO_K_2_WZ(PWT,MZF(PRWCT))) -#else - !Pin positions in the pools of MNH memory - CALL MNH_MEM_POSITION_PIN() - - CALL MNH_MEM_GET( ZFPOS1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFPOS2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFNEG1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFNEG2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBPOS1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBPOS2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBNEG1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBNEG2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMP1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMP2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMN1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMN2, IIU, IJU, IKU ) -! -! U component -! - CALL MXF_DEVICE(PRUCT,ZWORK) - CALL ADVEC_WENO_K_2_UX(HLBCX, PUT, ZWORK, ZMEAN, TZHALO2_UT%HALO2%WEST, TZHALO2_UT%HALO2%EAST, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DXM_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - IF (.NOT.L2D) THEN - CALL MXM_DEVICE(PRVCT,ZWORK) - CALL ADVEC_WENO_K_2_MY(HLBCY, PUT, ZWORK, ZMEAN, TZHALO2_UT%HALO2%NORTH, TZHALO2_UT%HALO2%SOUTH, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DYF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels - END IF -! -! PRUS = PRUS - DZF(WENO_K_2_MZ(PUT, MXM(PRWCT))) - CALL MXM_DEVICE(PRWCT,ZWORK) - CALL WENO_K_2_MZ(PUT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DZF_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! -! V component -! - IF (.NOT.L2D) THEN - CALL MYM_DEVICE(PRUCT,ZWORK) - CALL ADVEC_WENO_K_2_MX(HLBCX, PVT, ZWORK, ZMEAN, TZHALO2_VT%HALO2%WEST, TZHALO2_VT%HALO2%EAST, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DXF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - CALL MYF_DEVICE(PRVCT,ZWORK) - CALL ADVEC_WENO_K_2_VY(HLBCY, PVT, ZWORK, ZMEAN, TZHALO2_VT%HALO2%NORTH, TZHALO2_VT%HALO2%SOUTH, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DYM_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! -! PRVS = PRVS - DZF(WENO_K_2_MZ(PVT, MYM(PRWCT))) - CALL MYM_DEVICE(PRWCT,ZWORK) - CALL WENO_K_2_MZ(PVT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DZF_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels - END IF -! -! W component -! -! ZWORK = MZM(PRUCT) - CALL MZM_DEVICE(PRUCT,ZWORK) - CALL ADVEC_WENO_K_2_MX(HLBCX, PWT, ZWORK, ZMEAN, TZHALO2_WT%HALO2%WEST, TZHALO2_WT%HALO2%EAST, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DXF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - IF (.NOT.L2D) THEN -! ZWORK = MZM(PRVCT) - CALL MZM_DEVICE(PRVCT,ZWORK) - CALL ADVEC_WENO_K_2_MY(HLBCY, PWT, ZWORK, ZMEAN, TZHALO2_WT%HALO2%NORTH, TZHALO2_WT%HALO2%SOUTH, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DYF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels - END IF -! -! PRWS = PRWS - DZM(WENO_K_2_WZ(PWT,MZF(PRWCT))) - CALL MZF_DEVICE( PRWCT, ZWORK ) - CALL WENO_K_2_WZ(PWT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFNEG1(:,:,:), ZFNEG2(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBNEG1(:,:,:), ZBNEG2(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMN1(:,:,:), ZOMN2(:,:,:) ) - CALL DZM_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN - CALL MNH_MEM_RELEASE() -#endif -! -! -CASE(5) ! WENO 5 -#ifndef MNH_OPENACC -! -! U component -! - ZWORK = MXF(PRUCT) - CALL ADVEC_WENO_K_3_UX(HLBCX, PUT, ZWORK, ZMEAN) - CALL GET_HALO(ZMEAN)! Update HALO - PRUS = PRUS - DXM(ZMEAN) -! - IF (.NOT.L2D) THEN! 3D Case - ZWORK = MXM(PRVCT) - CALL ADVEC_WENO_K_3_MY(HLBCY, PUT, ZWORK, ZMEAN) - CALL GET_HALO(ZMEAN)! Update HALO - PRUS = PRUS - DYF(ZMEAN) - END IF -! - ZMEAN = WENO_K_3_MZ(PUT, MXM(PRWCT)) - CALL GET_HALO(ZMEAN)! Update HALO - maybe not necessary (T.Lunet) - PRUS = PRUS - DZF(ZMEAN) -! -! V component, only called in 3D case -! - IF (.NOT.L2D) THEN -! - ZWORK = MYM(PRUCT) - CALL ADVEC_WENO_K_3_MX(HLBCX, PVT, ZWORK, ZMEAN) - CALL GET_HALO(ZMEAN)! Update HALO - PRVS = PRVS - DXF(ZMEAN) -! - ZWORK = MYF(PRVCT) - CALL ADVEC_WENO_K_3_VY(HLBCY, PVT, ZWORK, ZMEAN) - CALL GET_HALO(ZMEAN)! Update HALO - PRVS = PRVS - DYM(ZMEAN) -! - ZMEAN = WENO_K_3_MZ(PVT, MYM(PRWCT)) - CALL GET_HALO(ZMEAN)! Update HALO - maybe not necessary (T.Lunet) - PRVS = PRVS - DZF(ZMEAN) -! - END IF -! -! W component -! - ZWORK = MZM(PRUCT) - CALL ADVEC_WENO_K_3_MX(HLBCX, PWT, ZWORK, ZMEAN) - CALL GET_HALO(ZMEAN)! Update HALO - PRWS = PRWS - DXF(ZMEAN) -! - IF (.NOT.L2D) THEN! 3D Case - ZWORK = MZM(PRVCT) - CALL ADVEC_WENO_K_3_MY(HLBCY, PWT, ZWORK, ZMEAN) - CALL GET_HALO(ZMEAN)! Update HALO - PRWS = PRWS - DYF(ZMEAN) - END IF -! - ZMEAN = WENO_K_3_WZ(PWT,MZF(PRWCT)) - CALL GET_HALO(ZMEAN)! Update HALO - maybe not necessary (T.Lunet) - PRWS = PRWS - DZM(ZMEAN) -#else - !Pin positions in the pools of MNH memory - CALL MNH_MEM_POSITION_PIN() - - CALL MNH_MEM_GET( ZFPOS1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFPOS2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFPOS3, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFNEG1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFNEG2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZFNEG3, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBPOS1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBPOS2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBPOS3, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBNEG1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBNEG2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZBNEG3, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMP1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMP2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMP3, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMN1, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMN2, IIU, IJU, IKU ) - CALL MNH_MEM_GET( ZOMN3, IIU, IJU, IKU ) -! -! U component -! - CALL MXF_DEVICE(PRUCT,ZWORK) - CALL ADVEC_WENO_K_3_UX(HLBCX, PUT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - CALL DXM_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - IF (.NOT.L2D) THEN - CALL MXM_DEVICE(PRVCT,ZWORK) - CALL ADVEC_WENO_K_3_MY(HLBCY, PUT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - CALL DYF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels - END IF -! - CALL MXM_DEVICE(PRWCT,ZWORK) - CALL WENO_K_3_MZ(PUT,ZWORK,ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - maybe not necessary (T.Lunet) - CALL DZF_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRUS(:,:,:) = PRUS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! -! V component -! - IF (.NOT.L2D) THEN - CALL MYM_DEVICE(PRUCT,ZWORK) - CALL ADVEC_WENO_K_3_MX(HLBCX, PVT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - CALL DXF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - CALL MYF_DEVICE(PRVCT,ZWORK) - CALL ADVEC_WENO_K_3_VY(HLBCY, PVT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - CALL DYM_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - CALL MYM_DEVICE(PRWCT,ZWORK) - CALL WENO_K_3_MZ(PVT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - maybe not necessary (T.Lunet) - CALL DZF_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRVS(:,:,:) = PRVS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels - END IF -! -! W component -! - CALL MZM_DEVICE(PRUCT,ZWORK) - CALL ADVEC_WENO_K_3_MX(HLBCX, PWT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - CALL DXF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - IF (.NOT.L2D) THEN - CALL MZM_DEVICE(PRVCT,ZWORK) - CALL ADVEC_WENO_K_3_MY(HLBCY, PWT, ZWORK, ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - CALL DYF_DEVICE(ZMEAN,ZWORK) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels - END IF -! - CALL MZF_DEVICE( PRWCT, ZWORK ) - CALL WENO_K_3_WZ(PWT,ZWORK,ZMEAN, & - ZFPOS1(:,:,:), ZFPOS2(:,:,:), ZFPOS3(:,:,:), & - ZFNEG1(:,:,:), ZFNEG2(:,:,:), ZFNEG3(:,:,:), & - ZBPOS1(:,:,:), ZBPOS2(:,:,:), ZBPOS3(:,:,:), & - ZBNEG1(:,:,:), ZBNEG2(:,:,:), ZBNEG3(:,:,:), & - ZOMP1(:,:,:), ZOMP2(:,:,:), ZOMP3(:,:,:), & - ZOMN1(:,:,:), ZOMN2(:,:,:), ZOMN3(:,:,:) ) - CALL GET_HALO_D(ZMEAN)! Update HALO - maybe not necessary (T.Lunet) - CALL DZM_DEVICE( ZMEAN, ZWORK ) -!$acc kernels - PRWS(:,:,:) = PRWS(:,:,:) - ZWORK(:,:,:) -!$acc end kernels -! - !Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN - CALL MNH_MEM_RELEASE() -#endif -! -! -END SELECT -! --------------------------------- -! acc update self(PRUS,PRVS,PRWS) - -!$acc end data - -#ifdef MNH_OPENACC -!Release all memory allocated with MNH_MEM_GET calls since beginning of subroutine -CALL MNH_MEM_RELEASE() -#endif - -IF (MPPDB_INITIALIZED) THEN - CALL MPPDB_CHECK(PRUS,"ADVECUVW_WENO_K end:PRUS") - CALL MPPDB_CHECK(PRVS,"ADVECUVW_WENO_K end:PRVS") - CALL MPPDB_CHECK(PRWS,"ADVECUVW_WENO_K end:PRWS") -END IF - - -END SUBROUTINE ADVECUVW_WENO_K diff --git a/src/ZSOLVER/contrav.f90 b/src/ZSOLVER/contrav.f90 deleted file mode 100644 index a1e367d3569d5ede930f11c592beccd279db5f0c..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/contrav.f90 +++ /dev/null @@ -1,965 +0,0 @@ -!MNH_LIC Copyright 1994-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! #################### - MODULE MODI_CONTRAV -! #################### -! -INTERFACE -! - SUBROUTINE CONTRAV(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, & - PRUCT,PRVCT,PRWCT,KADV_ORDER ) -! -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar -INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme -! -END SUBROUTINE CONTRAV -! -#ifdef MNH_OPENACC - SUBROUTINE CONTRAV_DEVICE(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, & - PRUCT,PRVCT,PRWCT,KADV_ORDER,ODATA_ON_DEVICE ) -! -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZY ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar -INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme -LOGICAL, OPTIONAL, INTENT(IN) :: ODATA_ON_DEVICE ! Is some of the data on the accelerator device -! -! -END SUBROUTINE CONTRAV_DEVICE -#endif -! -END INTERFACE -! -END MODULE MODI_CONTRAV -! -! -! -! ############################################################## - SUBROUTINE CONTRAV(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, & - PRUCT,PRVCT,PRWCT,KADV_ORDER ) -! ############################################################## -! -!!**** *CONTRAV * - computes the contravariant components from the -!! cartesian components -!! -!! PURPOSE -!! ------- -! This routine computes the contravariant components of vector -! defined by its cartesian components (U,V,W) , using the following -! formulae: -! UC = U / DXX -! VC = V / DYY -! ( ----------x ----------y ) -! ( ---z ---z ) -! 1 ( U V ) -! WC = --- ( W - DZX * --- - DZY * --- ) -! DZZ ( DXX DYY ) -! -! -! In the no-topography case, WC = W / DZZ -! -! -!!** METHOD -!! ------ -!! We employ the Shuman operators to compute the averages. The metric -!! coefficients PDXX, PDYY, PDZX, PDZY, PDZZ are dummy arguments -!! -!! -!! EXTERNAL -!! -------- -!! -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! -!! Module MODD_CONF : contains configuration variable -!! LFLAT : Logical for topography -!! = .TRUE. if Zs = 0 (Flat terrain) -!! -!! REFERENCE -!! --------- -!! Book2 of documentation (subroutine CONTRAV) -!! -!! -!! AUTHOR -!! ------ -!! J.L. Redelsperger * CNRM * -!! J.-P. Pinty * Laboratoire d'Aerologie* -!! -!! MODIFICATIONS -!! ------------- -!! Original 27/07/94 -!! Corrections 3/08/94 (by J.P. Lafore) -!! Corrections 17/10/94 (by J.P. Lafore) WC modified for w-advection -!! Corrections 19/01/11 (by J.P. Pinty) WC 4th order -!! Corrections 28/03/11 (by V.Masson) // of WC 4th order -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test -! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine -!---------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -USE MODD_CONF -USE MODD_PARAMETERS -USE MODD_GRID_n, ONLY: XZZ -! -USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll -USE MODE_ll -! -USE MODI_GET_HALO -! -USE MODE_MPPDB -! -IMPLICIT NONE -! -!* 0.1 declarations of arguments -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! Metric coefficients -! -! -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar -INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme -! -! -!* 0.2 declarations of local variables -! -REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,2),SIZE(PDXX,3)):: Z1,Z2 -INTEGER :: IIB,IIE,IJB,IJE,IKB,IKE -INTEGER :: IIU, IJU, IKU -INTEGER:: IW,IE,IS,IN ! Coordinate of forth order diffusion area -! -TYPE(LIST_ll), POINTER :: TZFIELD_U, TZFIELD_V, TZFIELD_DZX, TZFIELD_DZY -TYPE(HALO2LIST_ll), POINTER :: TZHALO2_U, TZHALO2_V, TZHALO2_DZX, TZHALO2_DZY -INTEGER :: IINFO_ll -!----------------------------------------------------------------------- -! -!* 1. Compute the horizontal contravariant components -! ----------------------------------------------- -! -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PRUT,"CONTRAV beg:PRUT") - CALL MPPDB_CHECK(PRVT,"CONTRAV beg:PRVT") - CALL MPPDB_CHECK(PRWT,"CONTRAV beg:PRWT") - CALL MPPDB_CHECK(PDXX,"CONTRAV beg:PDXX") - CALL MPPDB_CHECK(PDYY,"CONTRAV beg:PDYY") - CALL MPPDB_CHECK(PDZZ,"CONTRAV beg:PDZZ") - CALL MPPDB_CHECK(PDZX,"CONTRAV beg:PDZX") - CALL MPPDB_CHECK(PDZY,"CONTRAV beg:PDZY") -END IF -! -IIU= SIZE(PDXX,1) -IJU= SIZE(PDXX,2) -IKU= SIZE(PDXX,3) -! -CALL GET_INDICE_ll( IIB,IJB,IIE,IJE) -! -IKB=1+JPVEXT -IKE=IKU - JPVEXT -! -PRUCT(:,:,:) = PRUT(:,:,:) / PDXX(:,:,:) -PRVCT(:,:,:) = PRVT(:,:,:) / PDYY(:,:,:) -! -IF (KADV_ORDER == 4 ) THEN - IF( .NOT. LFLAT) THEN - NULLIFY(TZFIELD_U) - NULLIFY(TZFIELD_V) - CALL ADD3DFIELD_ll( TZFIELD_U, PRUCT, 'CONTRAV::PRUCT' ) - CALL ADD3DFIELD_ll( TZFIELD_V, PRVCT, 'CONTRAV::PRVCT' ) - CALL UPDATE_HALO_ll(TZFIELD_U,IINFO_ll) - CALL UPDATE_HALO_ll(TZFIELD_V,IINFO_ll) -!!$ IF( NHALO==1 ) THEN - NULLIFY(TZFIELD_DZX) - NULLIFY(TZFIELD_DZY) - CALL ADD3DFIELD_ll( TZFIELD_DZX, PDZX, 'CONTRAV::PDZX' ) - CALL ADD3DFIELD_ll( TZFIELD_DZY, PDZY, 'CONTRAV::PDZY' ) - NULLIFY(TZHALO2_U) - NULLIFY(TZHALO2_V) - NULLIFY(TZHALO2_DZX) - NULLIFY(TZHALO2_DZY) - CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU) - CALL UPDATE_HALO2_ll(TZFIELD_U, TZHALO2_U, IINFO_ll) - CALL UPDATE_HALO2_ll(TZFIELD_V, TZHALO2_V, IINFO_ll) - CALL UPDATE_HALO2_ll(TZFIELD_DZX, TZHALO2_DZX, IINFO_ll) - CALL UPDATE_HALO2_ll(TZFIELD_DZY, TZHALO2_DZY, IINFO_ll) -!!$ END IF - END IF -END IF -! -! -!* 2. Compute the vertical contravariant components (flat case) -! ------------------------------------ -! -IF (LFLAT) THEN - PRWCT(:,:,:) = PRWT(:,:,:) / PDZZ(:,:,:) - RETURN -END IF -! -!* 3. Compute the vertical contravariant components (general case) -! ------------------------------------ -! -Z1 = 0. -Z2 = 0. -! -IF (KADV_ORDER == 2 ) THEN -! - Z1(IIB:IIE,:,IKB:IKE+1)= & - (PRUCT(IIB:IIE,:,IKB:IKE+1)+PRUCT(IIB:IIE,:,IKB-1:IKE) ) & - *PDZX(IIB:IIE,:,IKB:IKE+1) *0.25 & - +(PRUCT(IIB+1:IIE+1,:,IKB:IKE+1)+PRUCT(IIB+1:IIE+1,:,IKB-1:IKE) ) & - *PDZX(IIB+1:IIE+1,:,IKB:IKE+1) *0.25 - - Z2(:,IJB:IJE,IKB:IKE+1)= & - (PRVCT(:,IJB:IJE,IKB:IKE+1)+PRVCT(:,IJB:IJE,IKB-1:IKE) ) & - *PDZY(:,IJB:IJE,IKB:IKE+1) *0.25 & - +(PRVCT(:,IJB+1:IJE+1,IKB:IKE+1)+PRVCT(:,IJB+1:IJE+1,IKB-1:IKE) ) & - *PDZY(:,IJB+1:IJE+1,IKB:IKE+1) *0.25 - PRWCT=0. - PRWCT(IIB:IIE,IJB:IJE,IKB:IKE+1) = & - ( PRWT(IIB:IIE,IJB:IJE,IKB:IKE+1) & - - Z1(IIB:IIE,IJB:IJE,IKB:IKE+1) & - - Z2(IIB:IIE,IJB:IJE,IKB:IKE+1) & - ) / PDZZ(IIB:IIE,IJB:IJE,IKB:IKE+1) -! -ELSE IF (KADV_ORDER == 4 ) THEN -! -!!$ IF (NHALO == 1) THEN - IF ( LWEST_ll() .AND. HLBCX(1)/='CYCL' ) THEN - IW=IIB+2 -1 - ELSE - IW=IIB+1 -1 - END IF - IE=IIE-1 -!!$ ELSE -!!$ IF (LWEST_ll()) THEN -!!$ IW=IIB+1 -!!$ ELSE -!!$ IW=IIB -!!$ END IF -!!$ IF (LEAST_ll() .AND. HLBCX(2)/='CYCL' ) THEN -!!$ IE=IIE-1 -!!$ ELSE -!!$ IE=IIE -!!$ END IF -!!$ END IF - ! -!!$ IF(NHALO == 1) THEN - IF ( LSOUTH_ll() .AND. HLBCY(1)/='CYCL' ) THEN - IS=IJB+2 -1 - ELSE - IS=IJB+1 -1 - END IF - IN=IJE-1 -!!$ ELSE -!!$ IF (LSOUTH_ll()) THEN -!!$ IS=IJB+1 -!!$ ELSE -!!$ IS=IJB -!!$ END IF -!!$ IF (LNORTH_ll() .AND. HLBCY(2)/='CYCL' ) THEN -!!$ IN=IJE-1 -!!$ ELSE -!!$ IN=IJE -!!$ END IF -!!$ END IF - ! - ! - !* 3.1 interior of the process subdomain -! -! - Z1(IW:IE,:,IKB:IKE+1)= & - 7.0*( (PRUCT(IW:IE,:,IKB:IKE+1)+PRUCT(IW:IE,:,IKB-1:IKE)) & - *( 9.0*PDZX(IW:IE,:,IKB:IKE+1)-(PDZX(IW+1:IE+1,:,IKB:IKE+1) & - +PDZX(IW:IE,:,IKB:IKE+1)+PDZX(IW-1:IE-1,:,IKB:IKE+1))/3.0)/8.0 * 0.5 & - +(PRUCT(IW+1:IE+1,:,IKB:IKE+1)+PRUCT(IW+1:IE+1,:,IKB-1:IKE)) & - *( 9.0*PDZX(IW+1:IE+1,:,IKB:IKE+1)-(PDZX(IW+2:IE+2,:,IKB:IKE+1) & - +PDZX(IW+1:IE+1,:,IKB:IKE+1)+PDZX(IW:IE,:,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 & - -( (PRUCT(IW-1:IE-1,:,IKB:IKE+1)+PRUCT(IW-1:IE-1,:,IKB-1:IKE)) & - *PDZX(IW-1:IE-1,:,IKB:IKE+1) *0.5 & - +(PRUCT(IW+2:IE+2,:,IKB:IKE+1)+PRUCT(IW+2:IE+2,:,IKB-1:IKE)) & - *PDZX(IW+2:IE+2,:,IKB:IKE+1) *0.5)/12.0 - -! - Z2(:,IS:IN,IKB:IKE+1)= & - 7.0*( (PRVCT(:,IS:IN,IKB:IKE+1)+PRVCT(:,IS:IN,IKB-1:IKE)) & - *( 9.0*PDZY(:,IS:IN,IKB:IKE+1)-(PDZY(:,IS+1:IN+1,IKB:IKE+1) & - +PDZY(:,IS:IN,IKB:IKE+1)+PDZY(:,IS-1:IN-1,IKB:IKE+1))/3.0)/8.0 * 0.5 & - +(PRVCT(:,IS+1:IN+1,IKB:IKE+1)+PRVCT(:,IS+1:IN+1,IKB-1:IKE)) & - *( 9.0*PDZY(:,IS+1:IN+1,IKB:IKE+1)-(PDZY(:,IS+2:IN+2,IKB:IKE+1) & - +PDZY(:,IS+1:IN+1,IKB:IKE+1)+PDZY(:,IS:IN,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 & - -( (PRVCT(:,IS-1:IN-1,IKB:IKE+1)+PRVCT(:,IS-1:IN-1,IKB-1:IKE)) & - *PDZY(:,IS-1:IN-1,IKB:IKE+1) *0.5 & - +(PRVCT(:,IS+2:IN+2,IKB:IKE+1)+PRVCT(:,IS+2:IN+2,IKB-1:IKE)) & - *PDZY(:,IS+2:IN+2,IKB:IKE+1) *0.5)/12.0 -! -!* 3.2 limits of the process subdomain (inside the whole domain or in cyclic conditions) -! -!!$ IF (NHALO==1) THEN - - Z1(IIE,:,IKB:IKE+1)= & - 7.0*( (PRUCT(IIE,:,IKB:IKE+1)+PRUCT(IIE,:,IKB-1:IKE)) & - *( 9.0*PDZX(IIE,:,IKB:IKE+1)-(PDZX(IIE+1,:,IKB:IKE+1) & - +PDZX(IIE,:,IKB:IKE+1)+PDZX(IIE-1,:,IKB:IKE+1))/3.0)/8.0 * 0.5 & - +(PRUCT(IIE+1,:,IKB:IKE+1)+PRUCT(IIE+1,:,IKB-1:IKE)) & - *( 9.0*PDZX(IIE+1,:,IKB:IKE+1)-(TZHALO2_DZX%HALO2%EAST(:,IKB:IKE+1) & - +PDZX(IIE+1,:,IKB:IKE+1)+PDZX(IIE,:,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 & - -( (PRUCT(IIE-1,:,IKB:IKE+1)+PRUCT(IIE-1,:,IKB-1:IKE)) & - *PDZX(IIE-1,:,IKB:IKE+1) *0.5 & - +(TZHALO2_U%HALO2%EAST(:,IKB:IKE+1)+TZHALO2_U%HALO2%EAST(:,IKB-1:IKE)) & - *TZHALO2_DZX%HALO2%EAST(:,IKB:IKE+1) *0.5)/12.0 -! - Z2(:,IJE,IKB:IKE+1)= & - 7.0*( (PRVCT(:,IJE,IKB:IKE+1)+PRVCT(:,IJE,IKB-1:IKE)) & - *( 9.0*PDZY(:,IJE,IKB:IKE+1)-(PDZY(:,IJE+1,IKB:IKE+1) & - +PDZY(:,IJE,IKB:IKE+1)+PDZY(:,IJE-1,IKB:IKE+1))/3.0)/8.0 * 0.5 & - +(PRVCT(:,IJE+1,IKB:IKE+1)+PRVCT(:,IJE+1,IKB-1:IKE)) & - *( 9.0*PDZY(:,IJE+1,IKB:IKE+1)-(TZHALO2_DZY%HALO2%NORTH(:,IKB:IKE+1) & - +PDZY(:,IJE+1,IKB:IKE+1)+PDZY(:,IJE,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 & - -( (PRVCT(:,IJE-1,IKB:IKE+1)+PRVCT(:,IJE-1,IKB-1:IKE)) & - *PDZY(:,IJE-1,IKB:IKE+1) *0.5 & - +(TZHALO2_V%HALO2%NORTH(:,IKB:IKE+1)+TZHALO2_V%HALO2%NORTH(:,IKB-1:IKE)) & - *TZHALO2_DZY%HALO2%NORTH(:,IKB:IKE+1) *0.5)/12.0 -!!$ END IF -! -!* 3.3 non-CYCLIC CASE IN THE X DIRECTION: 2nd order case -! - IF (HLBCX(1)/='CYCL' .AND. LWEST_ll()) THEN -! - Z1(IIB,:,IKB:IKE+1)= & - (PRUCT(IIB,:,IKB:IKE+1)+PRUCT(IIB,:,IKB-1:IKE) ) & - *PDZX(IIB,:,IKB:IKE+1) *0.25 & - +(PRUCT(IIB+1,:,IKB:IKE+1)+PRUCT(IIB+1,:,IKB-1:IKE) ) & - *PDZX(IIB+1,:,IKB:IKE+1) *0.25 - END IF -! - IF (HLBCX(2)/='CYCL' .AND. LEAST_ll()) THEN -! - Z1(IIE,:,IKB:IKE+1)= & - (PRUCT(IIE,:,IKB:IKE+1)+PRUCT(IIE,:,IKB-1:IKE) ) & - *PDZX(IIE,:,IKB:IKE+1) *0.25 & - +(PRUCT(IIE+1,:,IKB:IKE+1)+PRUCT(IIE+1,:,IKB-1:IKE) ) & - *PDZX(IIE+1,:,IKB:IKE+1) *0.25 - END IF -! -!* 3.4 non-CYCLIC CASE IN THE Y DIRECTION: 2nd order case -! - IF (HLBCY(1)/='CYCL' .AND. LSOUTH_ll()) THEN -! - Z2(:,IJB,IKB:IKE+1)= & - (PRVCT(:,IJB,IKB:IKE+1)+PRVCT(:,IJB,IKB-1:IKE) ) & - *PDZY(:,IJB,IKB:IKE+1) *0.25 & - +(PRVCT(:,IJB+1,IKB:IKE+1)+PRVCT(:,IJB+1,IKB-1:IKE) ) & - *PDZY(:,IJB+1,IKB:IKE+1) *0.25 -! - END IF -! - IF (HLBCY(2)/='CYCL' .AND. LNORTH_ll()) THEN -! - Z2(:,IJE,IKB:IKE+1)= & - (PRVCT(:,IJE,IKB:IKE+1)+PRVCT(:,IJE,IKB-1:IKE) ) & - *PDZY(:,IJE,IKB:IKE+1) *0.25 & - +(PRVCT(:,IJE+1,IKB:IKE+1)+PRVCT(:,IJE+1,IKB-1:IKE) ) & - *PDZY(:,IJE+1,IKB:IKE+1) *0.25 -! - END IF -! -!* 3.5 Vertical contyravariant wind -! -! -!!$ CALL GET_HALO(Z1) -!!$ CALL GET_HALO(Z2) -!!$ -!!$ CALL MPPDB_CHECK3DM("contrav ::Z1/Z2/ PDZZ",PRECISION,Z1,Z2,PDZZ) - PRWCT=0. - PRWCT(IIB:IIE,IJB:IJE,IKB:IKE+1) = & - ( PRWT(IIB:IIE,IJB:IJE,IKB:IKE+1) & - - Z1(IIB:IIE,IJB:IJE,IKB:IKE+1) & - - Z2(IIB:IIE,IJB:IJE,IKB:IKE+1) & - ) / PDZZ(IIB:IIE,IJB:IJE,IKB:IKE+1) -! -END IF -! -PRWCT(:,:,1) = - PRWCT(:,:,3) ! Mirror hypothesis -! -IF (KADV_ORDER == 4 ) THEN - CALL CLEANLIST_ll(TZFIELD_U) - CALL CLEANLIST_ll(TZFIELD_V) -!!$ IF (NHALO==1) THEN - CALL CLEANLIST_ll(TZFIELD_DZX) - CALL CLEANLIST_ll(TZFIELD_DZY) - CALL DEL_HALO2_ll(TZHALO2_U) - CALL DEL_HALO2_ll(TZHALO2_V) - CALL DEL_HALO2_ll(TZHALO2_DZX) - CALL DEL_HALO2_ll(TZHALO2_DZY) -!!$ END IF -END IF -!----------------------------------------------------------------------- -IF (MPPDB_INITIALIZED) THEN - !Check all OUT arrays - CALL MPPDB_CHECK(PRUCT,"CONTRAV end:PRUCT") - CALL MPPDB_CHECK(PRVCT,"CONTRAV end:PRVCT") - CALL MPPDB_CHECK(PRWCT,"CONTRAV end:PRWCT") -END IF -! -END SUBROUTINE CONTRAV -! -#ifdef MNH_OPENACC -! ############################################################## - SUBROUTINE CONTRAV_DEVICE(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, & - PRUCT,PRVCT,PRWCT,KADV_ORDER,ODATA_ON_DEVICE ) -! ############################################################## -! -!!**** *CONTRAV * - computes the contravariant components from the -!! cartesian components -!! -!! PURPOSE -!! ------- -! This routine computes the contravariant components of vector -! defined by its cartesian components (U,V,W) , using the following -! formulae: -! UC = U / DXX -! VC = V / DYY -! ( ----------x ----------y ) -! ( ---z ---z ) -! 1 ( U V ) -! WC = --- ( W - DZX * --- - DZY * --- ) -! DZZ ( DXX DYY ) -! -! -! In the no-topography case, WC = W / DZZ -! -! -!!** METHOD -!! ------ -!! We employ the Shuman operators to compute the averages. The metric -!! coefficients PDXX, PDYY, PDZX, PDZY, PDZZ are dummy arguments -!! -!! -!! EXTERNAL -!! -------- -!! MXF, MYF, MZM : Shuman functions (mean operators) -!! -!! Module MODI_SHUMAN : Interface for Shuman functions -!! -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! -!! Module MODD_CONF : contains configuration variable -!! LFLAT : Logical for topography -!! = .TRUE. if Zs = 0 (Flat terrain) -!! -!! REFERENCE -!! --------- -!! Book2 of documentation (subroutine CONTRAV) -!! -!! -!! AUTHOR -!! ------ -!! J.L. Redelsperger * CNRM * -!! J.-P. Pinty * Laboratoire d'Aerologie* -!! -!! MODIFICATIONS -!! ------------- -!! Original 27/07/94 -!! Corrections 3/08/94 (by J.P. Lafore) -!! Corrections 17/10/94 (by J.P. Lafore) WC modified for w-advection -!! Corrections 19/01/11 (by J.P. Pinty) WC 4th order -!! Corrections 28/03/11 (by V.Masson) // of WC 4th order -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test -! P. Wautelet 26/06/2019: optimisation for GPU + improve readability -!---------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -USE MODD_ARGSLIST_ll, ONLY: HALO2LIST_ll -USE MODD_CONF -USE MODD_GRID_n, ONLY: XZZ -USE MODD_PARAMETERS -! -USE MODE_ll -USE MODE_MPPDB -#ifdef MNH_OPENACC -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -use mode_msg -#endif -! -USE MODI_GET_HALO -USE MODI_SHUMAN -! -IMPLICIT NONE -! -!* 0.1 declarations of arguments -! -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type -CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y -REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z -! -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZX ! Metric coefficients -REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDZY ! Metric coefficients -! -! -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar -REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar -INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme -LOGICAL, OPTIONAL, INTENT(IN) :: ODATA_ON_DEVICE ! Is some of the data on the accelerator device -! -! -!* 0.2 declarations of local variables -! -integer :: ji, jj, jk -INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE -INTEGER :: IIU, IJU, IKU -INTEGER :: IW, IE, IS, IN ! Coordinate of fourth order diffusion area -INTEGER :: IINFO_ll -LOGICAL :: GDATA_ON_DEVICE -real :: ZTMP1, ZTMP2 ! Intermediate work variables -REAL, DIMENSION(:,:), POINTER , CONTIGUOUS :: ZU_EAST, ZV_NORTH, ZDZX_EAST, ZDZY_NORTH -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: Z1,Z2 ! Work arrays -TYPE(LIST_ll), POINTER :: TZFIELD_U, TZFIELD_V, TZFIELD_DZX, TZFIELD_DZY -TYPE(HALO2LIST_ll), SAVE, POINTER :: TZHALO2_U, TZHALO2_V, TZHALO2_DZX, TZHALO2_DZY -LOGICAL , SAVE :: GFIRST_CALL_CONTRAV_DEVICE = .TRUE. -! -LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH -! - -IF ( PRESENT(ODATA_ON_DEVICE) ) THEN - GDATA_ON_DEVICE = ODATA_ON_DEVICE -ELSE - GDATA_ON_DEVICE = .FALSE. -END IF -!----------------------------------------------------------------------- -! -!* 1. Compute the horizontal contravariant components -! ----------------------------------------------- -! -IF (MPPDB_INITIALIZED) THEN - !Check all IN arrays - CALL MPPDB_CHECK(PRUT,"CONTRAV beg:PRUT") - CALL MPPDB_CHECK(PRVT,"CONTRAV beg:PRVT") - CALL MPPDB_CHECK(PRWT,"CONTRAV beg:PRWT") - CALL MPPDB_CHECK(PDXX,"CONTRAV beg:PDXX") - CALL MPPDB_CHECK(PDYY,"CONTRAV beg:PDYY") - CALL MPPDB_CHECK(PDZZ,"CONTRAV beg:PDZZ") - CALL MPPDB_CHECK(PDZX,"CONTRAV beg:PDZX") - CALL MPPDB_CHECK(PDZY,"CONTRAV beg:PDZY") -END IF -! -IIU= SIZE(PDXX,1) -IJU= SIZE(PDXX,2) -IKU= SIZE(PDXX,3) - -!Pin positions in the pools of MNH memory -CALL MNH_MEM_POSITION_PIN() - -CALL MNH_MEM_GET( Z1, IIU, IJU, IKU ) -CALL MNH_MEM_GET( Z2, IIU, IJU, IKU ) - -GWEST = ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() ) -GEAST = ( HLBCX(2) /= 'CYCL' .AND. LEAST_ll() ) -GSOUTH = ( HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() ) -GNORTH = ( HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() ) -! -CALL GET_INDICE_ll( IIB,IJB,IIE,IJE) -! -IKB=1+JPVEXT -IKE=IKU - JPVEXT - -IF (KADV_ORDER == 4 ) THEN - IF( .NOT. LFLAT) THEN - IF ( GFIRST_CALL_CONTRAV_DEVICE ) THEN - GFIRST_CALL_CONTRAV_DEVICE = .FALSE. - NULLIFY(TZHALO2_U) - NULLIFY(TZHALO2_V) - NULLIFY(TZHALO2_DZX) - NULLIFY(TZHALO2_DZY) - CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU) - END IF - ZU_EAST => TZHALO2_U%HALO2%EAST - ZDZX_EAST => TZHALO2_DZX%HALO2%EAST - ZV_NORTH => TZHALO2_V%HALO2%NORTH - ZDZY_NORTH => TZHALO2_DZY%HALO2%NORTH - END IF -END IF - -CALL CONTRAV_DEVICE_DIM(& - PRUT,PRVT,PRWT,& - PDXX,PDYY,PDZZ,PDZX,PDZY,& - PRUCT,PRVCT,PRWCT,Z1,Z2,& - ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH) - -!Release all memory allocated with MNH_MEM_GET calls since last call to MNH_MEM_POSITION_PIN -CALL MNH_MEM_RELEASE() - -IF (MPPDB_INITIALIZED) THEN - !Check all OUT arrays - CALL MPPDB_CHECK(PRUCT,"CONTRAV end:PRUCT") - CALL MPPDB_CHECK(PRVCT,"CONTRAV end:PRVCT") - CALL MPPDB_CHECK(PRWCT,"CONTRAV end:PRWCT") -END IF - -CONTAINS - - SUBROUTINE CONTRAV_DEVICE_DIM(& - PRUT,PRVT,PRWT,& - PDXX,PDYY,PDZZ,PDZX,PDZY,& - PRUCT,PRVCT,PRWCT,Z1,Z2,& - ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH) - - IMPLICIT NONE - - REAL, DIMENSION(IIU, IJU, IKU) :: & - PRUT,PRVT,PRWT,& - PDXX,PDYY,PDZZ,PDZX,PDZY,& - PRUCT,PRVCT,PRWCT,Z1,Z2 - REAL :: ZU_EAST(IJU,IKU),ZV_NORTH(IIU,IKU),ZDZX_EAST(IJU,IKU),ZDZY_NORTH(IIU,IKU) - -! -! Begin Compute -! - -!$acc data present( PRUT, PRVT, PRWT, PDXX, PDYY, PDZZ, PDZX, PDZY, PRUCT, PRVCT, PRWCT, Z1, Z2 ) & -!$acc& present(ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH) - -IF (GDATA_ON_DEVICE) THEN -!PW TODO:remplacer (ailleurs aussi...) 1/PDXX... par PINV_PDXX (fait pour la turbulence...) cfr MNH/turb_hor_splt.f90 -!$acc kernels - PRUCT(:,:,:) = PRUT(:,:,:) / PDXX(:,:,:) - PRVCT(:,:,:) = PRVT(:,:,:) / PDYY(:,:,:) -!$acc end kernels -! acc update self(PRUCT,PRVCT) -ELSE - PRUCT(:,:,:) = PRUT(:,:,:) / PDXX(:,:,:) - PRVCT(:,:,:) = PRVT(:,:,:) / PDYY(:,:,:) -END IF -! -IF (KADV_ORDER == 4 ) THEN - IF( .NOT. LFLAT) THEN -!!$ NULLIFY(TZFIELD_U) -!!$ NULLIFY(TZFIELD_V) -!!$ CALL ADD3DFIELD_ll( TZFIELD_U, PRUCT, 'CONTRAV::PRUCT' ) -!!$ CALL ADD3DFIELD_ll( TZFIELD_V, PRVCT, 'CONTRAV::PRVCT' ) -!!$ CALL UPDATE_HALO_ll(TZFIELD_U,IINFO_ll) -!!$ CALL UPDATE_HALO_ll(TZFIELD_V,IINFO_ll) -!!$ !!$ IF( NHALO==1 ) THEN -!!$ NULLIFY(TZFIELD_DZX) -!!$ NULLIFY(TZFIELD_DZY) -!!$ CALL ADD3DFIELD_ll( TZFIELD_DZX, PDZX, 'CONTRAV::PDZX' ) -!!$ CALL ADD3DFIELD_ll( TZFIELD_DZY, PDZY, 'CONTRAV::PDZY' ) -!!$ IF ( GFIRST_CALL_CONTRAV_DEVICE ) THEN -!!$ GFIRST_CALL_CONTRAV_DEVICE = .FALSE. -!!$ NULLIFY(TZHALO2_U) -!!$ NULLIFY(TZHALO2_V) -!!$ NULLIFY(TZHALO2_DZX) -!!$ NULLIFY(TZHALO2_DZY) -!!$ CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU) -!!$ CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU) -!!$ CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU) -!!$ CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU) -!!$ END IF -!!$ CALL UPDATE_HALO2_ll(TZFIELD_U, TZHALO2_U, IINFO_ll) -!!$ CALL UPDATE_HALO2_ll(TZFIELD_V, TZHALO2_V, IINFO_ll) -!!$ CALL UPDATE_HALO2_ll(TZFIELD_DZX, TZHALO2_DZX, IINFO_ll) -!!$ CALL UPDATE_HALO2_ll(TZFIELD_DZY, TZHALO2_DZY, IINFO_ll) - ! - CALL GET_HALO2_DF(PRUCT,TZHALO2_U,'CONTRAV::PRUCT') - CALL GET_HALO2_DF(PRVCT,TZHALO2_V,'CONTRAV::PRVCT') - CALL GET_HALO2_DF(PDZX,TZHALO2_DZX,'CONTRAV::PDZX') - CALL GET_HALO2_DF(PDZY,TZHALO2_DZY,'CONTRAV::PDZY') - -!!$!$acc update device(PRUCT,PRVCT) -!!$ !!$ END IF -! - !PW: necessary because pointers does not work with OpenACC (PGI 16.1) -!!$ ALLOCATE(ZU_EAST(IJU,IKU),ZV_NORTH(IIU,IKU),ZDZX_EAST(IJU,IKU),ZDZY_NORTH(IIU,IKU)) -!!$ !$acc enter data create( zu_east, zv_north, zdzx_east, zdzy_north ) -!!$ !$acc kernels -!!$ ZU_EAST => TZHALO2_U%HALO2%EAST -!!$ ZDZX_EAST => TZHALO2_DZX%HALO2%EAST -!!$ ZV_NORTH => TZHALO2_V%HALO2%NORTH -!!$ ZDZY_NORTH => TZHALO2_DZY%HALO2%NORTH -!!$ !$acc end kernels -!!$!$acc update device(ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH) - END IF ! NOT FLAT -END IF ! KADV_ORDER == 4 -! -! -!* 2. Compute the vertical contravariant components (flat case) -! ------------------------------------ -! -FLAT: IF (LFLAT) THEN - IF (GDATA_ON_DEVICE) THEN -!$acc kernels - PRWCT(:,:,:) = PRWT(:,:,:) / PDZZ(:,:,:) -!$acc end kernels -! acc update self(PRWCT) - ELSE - PRWCT(:,:,:) = PRWT(:,:,:) / PDZZ(:,:,:) - END IF -ELSE -! -!* 3. Compute the vertical contravariant components (general case) -! ------------------------------------ -! -! Z1(:,:,:) = 0. -! Z2(:,:,:) = 0. -! -CALL MPPDB_CHECK3DM("contrav_device :: init Z1/Z2",PRECISION,Z1,Z2) -! -IF (KADV_ORDER == 2 ) THEN -#ifdef MNH_OPENACC - call Print_msg( NVERB_WARNING, 'GEN', 'CONTRAV', 'OpenACC: KADV_ORDER=2 and LFLAT=.TRUE. not yet tested' ) -#endif -!$acc kernels -! - !$mnh_do_concurrent(ji=iib:iie,jj=1:iju,jk=ikb:ike+1) - Z1(ji, jj, jk ) = ( PRUCT(ji, jj, jk ) + PRUCT(ji, jj, jk - 1 ) ) * PDZX (ji, jj, jk ) * 0.25 & - + ( PRUCT(ji + 1, jj, jk ) + PRUCT(ji + 1, jj, jk - 1 ) ) * PDZX (ji + 1, jj, jk ) * 0.25 - !$mnh_end_do() - !$mnh_do_concurrent(ji=1:iiu,jj=ijb:ije,jk=ikb:ike+1) - Z2(ji, jj, jk ) = ( PRVCT(ji, jj, jk) + PRVCT( ji, jj, jk - 1) ) * PDZY(ji, jj, jk) * 0.25 & - + ( PRVCT(ji, jj + 1, jk) + PRVCT( ji, jj + 1,jk - 1) ) * PDZY(ji, jj + 1, jk) * 0.25 - !$mnh_end_do() - - PRWCT(:,:,:)=0. - - !$mnh_do_concurrent(ji=iib:iie,jj=ijb:ije,jk=ikb:ike+1) - PRWCT(ji ,jj, jk ) = ( PRWT(ji ,jj, jk ) - Z1(ji ,jj, jk ) - Z2(ji ,jj, jk ) ) / PDZZ(ji ,jj, jk ) - !$mnh_end_do() -! -!$acc end kernels -ELSE IF (KADV_ORDER == 4 ) THEN -! -!!$ IF (NHALO == 1) THEN - IF ( GWEST ) THEN - IW=IIB+2 -1 - ELSE - IW=IIB+1 -1 - END IF - IE=IIE-1 -!!$ ELSE -!!$ IF ( GWEST ) THEN -!!$ IW=IIB+1 -!!$ ELSE -!!$ IW=IIB -!!$ END IF -!!$ IF ( GEAST ) THEN -!!$ IE=IIE-1 -!!$ ELSE -!!$ IE=IIE -!!$ END IF -!!$ END IF - ! -!!$ IF(NHALO == 1) THEN - IF ( GSOUTH ) THEN - IS=IJB+2 -1 - ELSE - IS=IJB+1 -1 - END IF - IN=IJE-1 -!!$ ELSE -!!$ IF ( GSOUTH ) THEN -!!$ IS=IJB+1 -!!$ ELSE -!!$ IS=IJB -!!$ END IF -!!$ IF ( GNORTH ) THEN -!!$ IN=IJE-1 -!!$ ELSE -!!$ IN=IJE -!!$ END IF -!!$ END IF - ! - ! - !* 3.1 interior of the process subdomain -!$acc kernels -! -! -!PW: OpenACC remarks: *computing only ztmp2 and reusing it at next iteration works -! but ji loop can not be collapsed -> 10x slower on GPU -! *ztmp1 and ztmp2 are not necessary but improve readability (no impact on performance) - !$mnh_do_concurrent(ji=IW:IE,jj=1:iju,jk=IKB:IKE+1) - ztmp1 = ( 9.0 * PDZX(ji, jj, jk ) - ( PDZX(ji+1, jj, jk ) + PDZX(ji, jj, jk ) + PDZX(ji-1, jj, jk ) ) / 3.0 ) / 16.0 - ztmp2 = ( 9.0 * PDZX(ji+1, jj, jk ) - ( PDZX(ji+2, jj, jk ) + PDZX(ji+1, jj, jk ) + PDZX(ji, jj, jk ) ) / 3.0 ) / 16.0 - Z1(ji, jj, jk ) = 7.0 * ( ( PRUCT(ji, jj, jk ) + PRUCT(ji, jj, jk-1 ) ) * ztmp1 & - + ( PRUCT(ji+1, jj, jk ) + PRUCT(ji+1, jj, jk-1 ) ) * ztmp2 ) / 12.0 & - - 0.5 * ( ( PRUCT(ji-1, jj, jk ) + PRUCT(ji-1, jj, jk-1 ) ) * PDZX(ji-1, jj, jk) & - + ( PRUCT(ji+2, jj, jk ) + PRUCT(ji+2, jj, jk-1 ) ) * PDZX(ji+2, jj, jk) ) / 12.0 - !$mnh_end_do() -! - !$mnh_do_concurrent(ji=1:iiu,jj=is:in,jk=IKB:IKE+1) - ztmp1 = ( 9.0 * PDZY(ji, jj, jk ) - ( PDZY(ji, jj+1, jk ) + PDZY(ji, jj, jk ) + PDZY(ji, jj-1, jk ) ) / 3.0 ) / 16.0 - ztmp2 = ( 9.0 * PDZY(ji, jj+1, jk ) - ( PDZY(ji, jj+2, jk ) + PDZY(ji, jj+1, jk ) + PDZY(ji, jj, jk ) ) / 3.0 ) / 16.0 - Z2(ji, jj, jk ) = 7.0 * ( ( PRVCT(ji, jj, jk ) + PRVCT(ji, jj, jk-1 ) ) * ztmp1 & - + ( PRVCT(ji, jj+1, jk ) + PRVCT(ji, jj+1, jk-1 ) ) * ztmp2 ) / 12.0 & - - 0.5 * ( ( PRVCT(ji, jj-1, jk ) + PRVCT(ji, jj-1, jk-1 ) ) * PDZY(ji, jj-1, jk ) & - + ( PRVCT(ji, jj+2, jk ) + PRVCT(ji, jj+2, jk-1 ) ) * PDZY(ji, jj+2, jk ) ) / 12.0 - !$mnh_end_do() -!$acc end kernels -! -!!$CALL MPPDB_CHECK3DM("contrav_device :: dom Z1/Z2",PRECISION,Z1,Z2) -! -!* 3.2 limits of the process subdomain (inside the whole domain or in cyclic conditions) -! -!!$ IF (NHALO==1) THEN -!$acc kernels async - !$mnh_do_concurrent(jj=1:iju,jk=IKB:IKE+1) - ztmp1 = ( 9.0 * PDZX(IIE, jj, jk ) - ( PDZX(IIE+1, jj, jk ) + PDZX(IIE, jj, jk ) + PDZX(IIE-1, jj, jk ) ) / 3.0 ) / 16.0 - ztmp2 = ( 9.0 * PDZX(IIE+1, jj, jk ) - ( ZDZX_EAST(jj, jk ) + PDZX(IIE+1, jj, jk ) + PDZX(IIE, jj, jk ) ) / 3.0 ) / 16.0 - Z1(IIE, jj, jk ) = 7.0 * ( ( PRUCT(IIE, jj, jk ) + PRUCT(IIE, jj, jk-1 ) ) * ztmp1 & - + ( PRUCT(IIE+1, jj, jk ) + PRUCT(IIE+1, jj, jk-1 ) ) * ztmp2 ) / 12.0 & - - 0.5 * ( ( PRUCT(IIE-1, jj, jk ) + PRUCT(IIE-1, jj, jk-1 ) ) * PDZX(IIE-1, jj, jk) & - + ( ZU_EAST (jj, jk ) + ZU_EAST (jj, jk-1 ) ) * ZDZX_EAST (jj, jk) ) / 12.0 - !$mnh_end_do() -!$acc end kernels -! -!$acc kernels async - !$mnh_do_concurrent(ji=1:iiu,jk=IKB:IKE+1) - ztmp1 = ( 9.0 * PDZY(ji, IJE, jk) - ( PDZY (ji, IJE+1, jk) + PDZY(ji, IJE, jk) + PDZY(ji, IJE-1, jk) ) / 3.0 ) / 16.0 - ztmp2 = ( 9.0 * PDZY(ji, IJE+1, jk) - ( ZDZY_NORTH(ji, jk) + PDZY(ji, IJE+1, jk) + PDZY(ji, IJE, jk) ) / 3.0 ) / 16.0 - Z2(ji, IJE, jk ) = 7.0 * ( ( PRVCT (ji, IJE, jk ) + PRVCT (ji, IJE, jk-1 ) ) * ztmp1 & - + ( PRVCT (ji, IJE+1, jk ) + PRVCT (ji, IJE+1, jk-1 ) ) * ztmp2 ) / 12.0 & - - 0.5 * ( ( PRVCT (ji, IJE-1, jk ) + PRVCT (ji, IJE-1, jk-1 ) ) * PDZY (ji, IJE-1, jk ) & - + ( ZV_NORTH(ji, jk ) + ZV_NORTH(ji, jk-1 ) ) * ZDZY_NORTH(ji, jk ) ) / 12.0 - !$mnh_end_do() -!$acc end kernels -!$acc wait -!!$ END IF -! -!* 3.3 non-CYCLIC CASE IN THE X DIRECTION: 2nd order case -! - IF ( GWEST ) THEN - !$acc kernels async - Z1(IIB, :, IKB:IKE+1 ) = ( PRUCT(IIB, :, IKB:IKE+1 ) + PRUCT(IIB, :, IKB-1:IKE ) ) * PDZX(IIB, :, IKB:IKE+1 ) * 0.25 & - + ( PRUCT(IIB+1, :, IKB:IKE+1 ) + PRUCT(IIB+1, :, IKB-1:IKE ) ) * PDZX(IIB+1, :, IKB:IKE+1 ) * 0.25 - !$acc end kernels - END IF -! - IF ( GEAST ) THEN - !$acc kernels async - Z1(IIE, :, IKB:IKE+1 ) = ( PRUCT(IIE, :, IKB:IKE+1 ) + PRUCT(IIE, :, IKB-1:IKE ) ) * PDZX(IIE, :, IKB:IKE+1 ) * 0.25 & - + ( PRUCT(IIE+1, :, IKB:IKE+1 ) + PRUCT(IIE+1, :, IKB-1:IKE ) ) * PDZX(IIE+1, :, IKB:IKE+1 ) * 0.25 - !$acc end kernels - END IF -! -!* 3.4 non-CYCLIC CASE IN THE Y DIRECTION: 2nd order case -! - IF ( GSOUTH ) THEN - !$acc kernels async - Z2(:, IJB, IKB:IKE+1 ) = ( PRVCT(:, IJB, IKB:IKE+1 ) + PRVCT(:, IJB, IKB-1:IKE ) ) * PDZY(:, IJB, IKB:IKE+1 ) * 0.25 & - + ( PRVCT(:, IJB+1, IKB:IKE+1 ) + PRVCT(:, IJB+1, IKB-1:IKE ) ) * PDZY(:, IJB+1, IKB:IKE+1 ) * 0.25 - !$acc end kernels - END IF -! - IF ( GNORTH ) THEN - !$acc kernels async - Z2(:, IJE, IKB:IKE+1 ) = ( PRVCT(:, IJE, IKB:IKE+1 ) + PRVCT(:, IJE, IKB-1:IKE ) ) * PDZY(:, IJE, IKB:IKE+1 ) * 0.25 & - + ( PRVCT(:, IJE+1, IKB:IKE+1 ) + PRVCT(:, IJE+1, IKB-1:IKE ) ) * PDZY(:, IJE+1, IKB:IKE+1 ) * 0.25 - !$acc end kernels - END IF -!$acc wait -! -!* 3.5 Vertical contyravariant wind -! -! -!$acc kernels -!!$ CALL GET_HALO(Z1) -!!$ CALL GET_HALO(Z2) -!!$ -!!$ CALL MPPDB_CHECK3DM("contrav_device ::Z1/Z2/ PDZZ",PRECISION,Z1,Z2,PDZZ) - PRWCT(:,:,:)=0. - !$mnh_do_concurrent (ji=iib:iie,jj=ijb:ije,jk=ikb:ike+1) - PRWCT(ji ,jj, jk ) = ( PRWT(ji ,jj, jk ) - Z1(ji ,jj, jk ) - Z2(ji ,jj, jk ) ) / PDZZ(ji ,jj, jk ) - !$mnh_end_do() -!$acc end kernels -! -CALL MPPDB_CHECK3DM("contrav_device :: PRWCT/Z1/Z2",PRECISION,PRWCT,Z1,Z2) -! -END IF -! -!$acc kernels -PRWCT(:,:,1) = - PRWCT(:,:,3) ! Mirror hypothesis -!$acc end kernels -! acc update self(PRWCT) -! -IF (KADV_ORDER == 4 ) THEN -!!$!$acc exit data delete( zu_east, zv_north, zdzx_east, zdzy_north ) -!!$ DEALLOCATE(ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH) -!!$ CALL CLEANLIST_ll(TZFIELD_U) -!!$ CALL CLEANLIST_ll(TZFIELD_V) -!!$ !!$ IF (NHALO==1) THEN -!!$ CALL CLEANLIST_ll(TZFIELD_DZX) -!!$ CALL CLEANLIST_ll(TZFIELD_DZY) -!!$ CALL DEL_HALO2_ll(TZHALO2_U) -!!$ CALL DEL_HALO2_ll(TZHALO2_V) -!!$ CALL DEL_HALO2_ll(TZHALO2_DZX) -!!$ CALL DEL_HALO2_ll(TZHALO2_DZY) -!!$ !!$ END IF -END IF - -END IF FLAT - -!$acc end data - -! -! End Compute -! - - END SUBROUTINE CONTRAV_DEVICE_DIM - -!----------------------------------------------------------------------- -END SUBROUTINE CONTRAV_DEVICE -#endif diff --git a/src/ZSOLVER/modeln.f90 b/src/ZSOLVER/modeln.f90 deleted file mode 100644 index 4f635b6ff3a2f6bceebe945be752984869292266..0000000000000000000000000000000000000000 --- a/src/ZSOLVER/modeln.f90 +++ /dev/null @@ -1,2480 +0,0 @@ -!MNH_LIC Copyright 1994-2022 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -! ################### - MODULE MODI_MODEL_n -! ################### -! -INTERFACE -! - SUBROUTINE MODEL_n(KTCOUNT,OEXIT) -! -INTEGER, INTENT(IN) :: KTCOUNT ! temporal loop index of model KMODEL -LOGICAL, INTENT(INOUT):: OEXIT ! switch for the end of the temporal loop -! -END SUBROUTINE MODEL_n -! -END INTERFACE -! -END MODULE MODI_MODEL_n - -! ################################### - SUBROUTINE MODEL_n(KTCOUNT, OEXIT) -! ################################### -! -!!**** *MODEL_n * -monitor of the model version _n -!! -!! PURPOSE -!! ------- -! The purpose of this routine is to build up a typical model version -! by sequentially calling the specialized routines. -! -!!** METHOD -!! ------ -!! Some preliminary initializations are performed in the first section. -!! Then, specialized routines are called to update the guess of the future -!! instant XRxxS of the variable xx by adding the effects of all the -!! different sources of evolution. -!! -!! (guess of xx at t+dt) * Rhod_ref * Jacobian -!! XRxxS = ------------------------------------------- -!! 2 dt -!! -!! At this level, the informations are transferred with a USE association -!! from the INIT step, where the modules have been previously filled. The -!! transfer to the subroutines computing each source term is performed by -!! argument in order to avoid repeated compilations of these subroutines. -!! This monitor model_n, must therefore be duplicated for each model, -!! model1 corresponds in this case to the outermost model, model2 is used -!! for the first level of gridnesting,.... -!! The effect of all parameterizations is computed in PHYS_PARAM_n, which -!! is itself a monitor. This is due to a possible large number of -!! parameterizations, which can be activated and therefore, will require a -!! very large list of arguments. To circumvent this problem, we transfer by -!! a USE association, the necessary informations in this monitor, which will -!! dispatch the pertinent information to every parametrization. -!! Some elaborated diagnostics, LES tools, budget storages are also called -!! at this level because they require informations about the fields at every -!! timestep. -!! -!! -!! EXTERNAL -!! -------- -!! Subroutine IO_File_open: to open a file -!! Subroutine WRITE_DESFM: to write the descriptive part of a FMfile -!! Subroutine WRITE_LFIFM: to write the binary part of a FMfile -!! Subroutine SET_MASK : to compute all the masks selected for budget -!! computations -!! Subroutine BOUNDARIES : set the fields at the marginal points in every -!! directions according the selected boundary conditions -!! Subroutine INITIAL_GUESS: initializes the guess of the future instant -!! Subroutine LES_FLX_SPECTRA: computes the resolved fluxes and the -!! spectra of some quantities when running in LES mode. -!! Subroutine ADVECTION: computes the advection terms. -!! Subroutine DYN_SOURCES: computes the curvature, Coriolis, gravity terms. -!! Subroutine NUM_DIFF: applies the fourth order numerical diffusion. -!! Subroutine RELAXATION: performs the relaxation to Larger Scale fields -!! in the upper levels and outermost vertical planes -!! Subroutine PHYS_PARAM_n : computes the parameterized physical terms -!! Subroutine RAD_BOUND: prepares the velocity normal components for the bc. -!! Subroutine RESOLVED_CLOUD : computes the sources terms for water in any -!! form -!! Subroutine PRESSURE : computes the pressure gradient term and the -!! absolute pressure -!! Subroutine EXCHANGE : updates the halo of each subdomains -!! Subroutine ENDSTEP : advances in time the fields. -!! Subroutines UVW_LS_COUPLING and SCALAR_LS_COUPLING: -!! compute the large scale fields, used to -!! couple Model_n with outer informations. -!! Subroutine ENDSTEP_BUDGET: writes the budget informations. -!! Subroutine IO_File_close: closes a file -!! Subroutine DATETIME_CORRECTDATE: transform the current time in GMT -!! Subroutine FORCING : computes forcing terms -!! Subroutine ADD3DFIELD_ll : add a field to 3D-list -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! MODD_DYN -!! MODD_CONF -!! MODD_NESTING -!! MODD_BUDGET -!! MODD_PARAMETERS -!! MODD_CONF_n -!! MODD_CURVCOR_n -!! MODD_DYN_n -!! MODD_DIM_n -!! MODD_ADV_n -!! MODD_FIELD_n -!! MODD_LSFIELD_n -!! MODD_GRID_n -!! MODD_METRICS_n -!! MODD_LBC_n -!! MODD_PARAM_n -!! MODD_REF_n -!! MODD_LUNIT_n -!! MODD_OUT_n -!! MODD_TIME_n -!! MODD_TURB_n -!! MODD_CLOUDPAR_n -!! MODD_TIME -!! -!! REFERENCE -!! --------- -!! -!! AUTHOR -!! ------ -!! J.-P. Pinty * LA * -!! -!! MODIFICATIONS -!! ------------- -!! Original 15/09/94 -!! Modification 20/10/94 (J.Stein) for the outputs and abs_layers routines -!! Modification 10/11/94 (J.Stein) change ABS_LAYER_FIELDS call -!! Modification 16/11/94 (J.Stein) add call to the renormalization -!! Modification 17/11/94 (J.-P. Lafore and J.-P. Pinty) call NUM_DIFF -!! Modification 08/12/94 (J.Stein) cleaning + remove (RENORM + ABS_LAYER.. -!! ..) + add RELAXATION + LS fiels in the arguments -!! Modification 19/12/94 (J.Stein) switch for the num diff -!! Modification 22/12/94 (J.Stein) update tdtcur + change dyn_source call -!! Modification 05/01/95 (J.Stein) add the parameterization monitor -!! Modification 09/01/95 (J.Stein) add the 1D switch -!! Modification 10/01/95 (J.Stein) displace the TDTCUR computation -!! Modification 03/01/95 (J.-P. Lafore) Absolute pressure diagnosis -!! Modification Jan 19, 1995 (J. Cuxart) Shunt the DYN_SOURCES in 1D cases. -!! Modification Jan 24, 1995 (J. Stein) Interchange Boundaries and -!! Initial_guess to correct a bug in 2D configuration -!! Modification Feb 02, 1995 (I.Mallet) update BOUNDARIES and RAD_BOUND -!! calls -!! Modification Mar 10, 1995 (I.Mallet) add call to SET_COUPLING -!! March,21, 1995 (J. Stein) remove R from the historical var. -!! March,26, 1995 (J. Stein) add the EPS variable -!! April 18, 1995 (J. Cuxart) add the LES call -!! Sept 20,1995 (Lafore) coupling for the dry mass Md -!! Nov 2,1995 (Stein) displace the temporal counter increase -!! Jan 2,1996 (Stein) rm the test on the temporal counter -!! Modification Feb 5,1996 (J. Vila) implementation new advection -!! schemes for scalars -!! Modification Feb 20,1996 (J.Stein) doctor norm -!! Dec95 - Jul96 (Georgelin, Pinty, Mari, Suhre) FORCING -!! June 17,1996 (Vincent, Lafore, Jabouille) -!! statistics of computing time -!! Aug 8, 1996 (K. Suhre) add chemistry -!! October 12, 1996 (J. Stein) save the PSRC value -!! Sept 05,1996 (V.Masson) print of loop index for debugging -!! purposes -!! July 22,1996 (Lafore) improve write of computing time statistics -!! July 29,1996 (Lafore) nesting introduction -!! Aug. 1,1996 (Lafore) synchronization between models -!! Sept. 4,1996 (Lafore) modification of call to routine SET_COUPLING -!! now split in 2 routines -!! (UVW_LS_COUPLING and SCALAR_LS_COUPLING) -!! Sept 5,1996 (V.Masson) print of loop index for debugging -!! purposes -!! Sept 25,1996 (V.Masson) test for coupling performed here -!! Oct. 29,1996 (Lafore) one-way nesting implementation -!! Oct. 12,1996 (J. Stein) save the PSRC value -!! Dec. 12,1996 (Lafore) change call to RAD_BOUND -!! Dec. 21,1996 (Lafore) two-way nesting implementation -!! Mar. 12,1997 (Lafore) introduction of "surfacic" LS fields -!! Nov 18, 1996 (J.-P. Pinty) FORCING revisited (translation) -!! Dec 04, 1996 (J.-P. Pinty) include mixed-phase clouds -!! Dec 20, 1996 (J.-P. Pinty) update the budgets -!! Dec 23, 1996 (J.-P. Pinty) add the diachronic file control -!! Jan 11, 1997 (J.-P. Pinty) add the deep convection control -!! Dec 20,1996 (V.Masson) call boundaries before the writing -!! Fev 25, 1997 (P.Jabouille) modify the LES tools -!! April 3,1997 (Lafore) merging of the nesting -!! developments on MASTER3 -!! Jul. 8,1997 (Lafore) print control for nesting (NVERB>=7) -!! Jul. 28,1997 (Masson) supress LSTEADY_DMASS -!! Aug. 19,1997 (Lafore) full Clark's formulation introduction -!! Sept 26,1997 (Lafore) LS source calculation at restart -!! (temporarily test to have LS at instant t) -!! Jan. 28,1998 (Bechtold) add SST forcing -!! fev. 10,1998 (Lafore) RHODJ computation and storage for budget -!! Jul. 10,1998 (Stein ) sequentiel loop for nesting -!! Apr. 07,1999 (Stein ) cleaning of the nesting subroutines -!! oct. 20,1998 (Jabouille) // -!! oct. 20,2000 (J.-P. Pinty) add the C2R2 scheme -!! fev. 01,2001 (D.Gazen) add module MODD_NSV for NSV variables -!! mar, 4,2002 (V.Ducrocq) call to temporal series -!! mar, 8, 2001 (V. Masson) advection of perturbation of theta in neutral cases. -!! Nov, 6, 2002 (V. Masson) time counters for budgets & LES -!! mars 20,2001 (Pinty) add ICE4 and C3R5 options -!! jan. 2004 (Masson) surface externalization -!! sept 2004 (M. Tomasini) Cloud mixing length modification -!! june 2005 (P. Tulet) add aerosols / dusts -!! Jul. 2005 (N. Asencio) two_way and phys_param calls: -!! Add the surface parameters : precipitating -!! hydrometeors, Short and Long Wave , MASKkids array -!! Fev. 2006 (M. Leriche) add aqueous phase chemistry -!! april 2006 (T.Maric) Add halo related to 4th order advection scheme -!! May 2006 Remove KEPS -!! Oct 2008 (C.Lac) FIT for variables advected with PPM -!! July 2009 : Displacement of surface diagnostics call to be -!! coherent with surface diagnostics obtained with DIAG -!! 10/11/2009 (P. Aumond) Add mean moments -!! Nov, 12, 2009 (C. Barthe) add cloud electrification and lightning flashes -!! July 2010 (M. Leriche) add ice phase chemical species -!! April 2011 (C.Lac) : Remove instant M -!! April 2011 (C.Lac, V.Masson) : Time splitting for advection -!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test -!! P. Tulet Nov 2014 accumulated moles of aqueous species that fall at the surface -!! Dec 2014 (C.Lac) : For reproducibility START/RESTA -!! J.Escobar 20/04/2015: missing UPDATE_HALO before UPDATE_HALO2 -!! July, 2015 (O.Nuissier/F.Duffourg) Add microphysics diagnostic for -!! aircraft, ballon and profiler -!! C.Lac 11/09/2015: correction of the budget due to FIT temporal scheme -!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 -!! Sep 2015 (S. Bielli) : Remove YDADFILE from argument call -! of write_phys_param -!! J.Escobar : 19/04/2016 : Pb IOZ/NETCDF , missing OPARALLELIO=.FALSE. for PGD files -!! M.Mazoyer : 04/2016 DTHRAD used for radiative cooling when LACTIT -!!! Modification 01/2016 (JP Pinty) Add LIMA -!! 06/2016 (G.Delautier) phasage surfex 8 -!! M.Leriche : 03/2016 Move computation of accumulated chem. in rain to ch_monitor -!! 09/2016 Add filter on negative values on AERDEP SV before relaxation -!! 10/2016 (C.Lac) _ Correction on the flag for Strang splitting -!! to insure reproducibility between START and RESTA -!! _ Add OSPLIT_WENO -!! _ Add droplet deposition -!! 10/2016 (M.Mazoyer) New KHKO output fields -!! P.Wautelet : 11/07/2016 : removed MNH_NCWRIT define -!! 09/2017 Q.Rodier add LTEND_UV_FRC -!! 10/2017 (C.Lac) Necessity to have chemistry processes as -!! the las process modifying XRSVS -!! 01/2018 (G.Delautier) SURFEX 8.1 -!! 03/2018 (P.Wautelet) replace ADD_FORECAST_TO_DATE by DATETIME_CORRECTDATE -!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O -!! 07/2017 (V. Vionnet) : Add blowing snow scheme -!! S. Riette : 11/2016 Add ZPABST to keep pressure constant during timestep -!! 01/2018 (C.Lac) Add VISCOSITY -!! Philippe Wautelet: 21/01/2019: add LIO_ALLOW_NO_BACKUP and LIO_NO_WRITE to modd_io_ll -! to allow to disable writes (for bench purposes) -! P. Wautelet 07/02/2019: remove OPARALLELIO argument from open and close files subroutines -! (nsubfiles_ioz is now determined in IO_File_add2list) -!! 02/2019 C.Lac add rain fraction as an output field -!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes -! P. Wautelet 28/03/2019: use MNHTIME for time measurement variables -! P. Wautelet 28/03/2019: use TFILE instead of unit number for set_iluout_timing -! P. Wautelet 19/04/2019: removed unused dummy arguments and variables -! P. Wautelet 26/04/2019: replace non-standard FLOAT function by REAL function -! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine -! J. Escobar 09/07/2019: norme Doctor -> Rename Module Type variable TZ -> T -! J. Escobar 09/07/2019: for bug in management of XLSZWSM variable, add/use specific 2D TLSFIELD2D_ll pointer -! P. Wautelet 23/07/2019: OpenACC: move data creations from resolved_cloud to modeln and optimize updates -! P. Wautelet 13/09/2019: budget: simplify and modernize date/time management -! J. Escobar 27/09/2019: add missing report timing of RESOLVED_ELEC -! P. Wautelet 02-03/2020: use the new data structures and subroutines for budgets -! P. Wautelet 12/10/2020: Write_les_n: remove HLES_AVG dummy argument and group all 4 calls -! F. Auguste 01/02/2021: add IBM -! T. Nagel 01/02/2021: add turbulence recycling -! P. Wautelet 19/02/2021: add NEGA2 term for SV budgets -! J.L. Redelsperger 03/2021: add Call NHOA_COUPLN (coupling O & A LES version) -!!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_2D_FRC -USE MODD_ADV_n -USE MODD_AIRCRAFT_BALLOON -USE MODD_ARGSLIST_ll, ONLY : LIST_ll -USE MODD_BAKOUT -USE MODD_BIKHARDT_n -USE MODD_BLANK_n -USE MODD_BLOWSNOW -USE MODD_BLOWSNOW_n -use modd_budget, only: cbutype, lbu_ru, lbu_rv, lbu_rw, lbudget_u, lbudget_v, lbudget_w, lbudget_sv, lbu_enable, & - NBUDGET_U, NBUDGET_V, NBUDGET_W, NBUDGET_SV1, nbumod, nbutime, & - tbudgets, tburhodj, & - xtime_bu, xtime_bu_process -USE MODD_CH_AERO_n, ONLY: XSOLORG, XMI -USE MODD_CH_MNHC_n, ONLY: LUSECHEM,LCH_CONV_LINOX,LUSECHAQ,LUSECHIC, & - LCH_INIT_FIELD -USE MODD_CLOUD_MF_n -USE MODD_CLOUDPAR_n -USE MODD_CONF -USE MODD_CONF_n -USE MODD_CURVCOR_n -USE MODD_DEEP_CONVECTION_n -USE MODD_DIM_n -USE MODD_DRAG_n -USE MODD_DUST, ONLY: LDUST -USE MODD_DYN -USE MODD_DYN_n -USE MODD_DYNZD -USE MODD_DYNZD_n -USE MODD_ELEC_DESCR -USE MODD_EOL_MAIN -USE MODD_FIELD_n -USE MODD_FRC -USE MODD_FRC_n -USE MODD_GET_n -USE MODD_GRID, ONLY: XLONORI,XLATORI -USE MODD_GRID_n -USE MODD_IBM_PARAM_n, ONLY: CIBM_ADV, LIBM, LIBM_TROUBLE, XIBM_LS -USE MODD_ICE_C1R3_DESCR, ONLY: XRTMIN_C1R3=>XRTMIN -USE MODD_IO, ONLY: LIO_NO_WRITE, TFILEDATA, TFILE_SURFEX, TFILE_DUMMY -USE MODD_LBC_n -USE MODD_LES -USE MODD_LES_BUDGET -USE MODD_LIMA_PRECIP_SCAVENGING_n -USE MODD_LSFIELD_n -USE MODD_LUNIT, ONLY: TOUTDATAFILE -USE MODD_LUNIT_n, ONLY: TDIAFILE,TINIFILE,TINIFILEPGD,TLUOUT -USE MODD_MEAN_FIELD -USE MODD_MEAN_FIELD_n -USE MODD_METRICS_n -USE MODD_MNH_SURFEX_n -USE MODD_NESTING -USE MODD_NSV -USE MODD_NUDGING_n -USE MODD_OUT_n -USE MODD_PARAM_C1R3, ONLY: NSEDI => LSEDI, NHHONI => LHHONI -USE MODD_PARAM_C2R2, ONLY: NSEDC => LSEDC, NRAIN => LRAIN, NACTIT => LACTIT,LACTTKE,LDEPOC -USE MODD_PARAMETERS -USE MODD_PARAM_ICE, ONLY: LWARM,LSEDIC,LCONVHG,LDEPOSC -USE MODD_PARAM_LIMA, ONLY: MSEDC => LSEDC, MWARM => LWARM, MRAIN => LRAIN, & - MACTIT => LACTIT, LSCAV, LCOLD, & - MSEDI => LSEDI, MHHONI => LHHONI, LHAIL, & - XRTMIN_LIMA=>XRTMIN, MACTTKE=>LACTTKE -USE MODD_PARAM_MFSHALL_n -USE MODD_PARAM_n -USE MODD_PAST_FIELD_n -USE MODD_PRECIP_n -use modd_precision, only: MNHTIME -USE MODD_PROFILER_n -USE MODD_RADIATIONS_n, ONLY: XTSRAD,XSCAFLASWD,XDIRFLASWD,XDIRSRFSWD, XAER, XDTHRAD -USE MODD_RAIN_ICE_DESCR, ONLY: XRTMIN -USE MODD_RECYCL_PARAM_n, ONLY: LRECYCL -USE MODD_REF, ONLY: LCOUPLES -USE MODD_REF_n -USE MODD_SALT, ONLY: LSALT -USE MODD_SERIES, ONLY: LSERIES -USE MODD_SERIES_n, ONLY: NFREQSERIES -USE MODD_STATION_n -USE MODD_SUB_MODEL_n -USE MODD_TIME -USE MODD_TIME_n -USE MODD_TIMEZ -USE MODD_TURB_CLOUD, ONLY: NMODEL_CLOUD,CTURBLEN_CLOUD,XCEI -USE MODD_TURB_n -#ifdef MNH_COMPILER_CCE -USE MODD_TURB_n, ONLY: VSIGQSAT_MODD => VSIGQSAT -#endif - USE MODD_VISCOSITY -! -use mode_budget, only: Budget_store_init, Budget_store_end -USE MODE_DATETIME -USE MODE_ELEC_ll -USE MODE_GRIDCART -USE MODE_GRIDPROJ -USE MODE_IO_FIELD_WRITE, only: IO_Field_user_write, IO_Fieldlist_write, IO_Header_write -USE MODE_IO_FILE, only: IO_File_close, IO_File_open -USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list -USE MODE_ll -#ifdef MNH_IOLFI -use mode_menu_diachro, only: MENU_DIACHRO -#endif -USE MODE_MNH_TIMING -#ifdef MNH_OPENACC -USE MODE_MNH_ZWORK, ONLY: MNH_MEM_GET, MNH_MEM_POSITION_PIN, MNH_MEM_RELEASE -#endif -USE MODE_MODELN_HANDLER -USE MODE_MPPDB -USE MODE_MSG -USE MODE_ONE_WAY_n -use mode_write_les_n, only: Write_les_n -use mode_write_lfifmn_fordiachro_n, only: WRITE_LFIFMN_FORDIACHRO_n -USE MODE_WRITE_PROFILER_n, ONLY: WRITE_PROFILER_n -! -USE MODI_ADDFLUCTUATIONS -USE MODI_ADVECTION_METSV -USE MODI_ADVECTION_UVW -USE MODI_ADVECTION_UVW_CEN -USE MODI_ADV_FORCING_n -USE MODI_AER_MONITOR_n -USE MODI_AIRCRAFT_BALLOON -USE MODI_BLOWSNOW -USE MODI_BOUNDARIES -USE MODI_BUDGET_FLAGS -USE MODI_CART_COMPRESS -USE MODI_CH_MONITOR_n -USE MODI_DIAG_SURF_ATM_N -USE MODI_DYN_SOURCES -USE MODI_END_DIAG_IN_RUN -USE MODI_ENDSTEP -USE MODI_ENDSTEP_BUDGET -USE MODI_EXCHANGE -USE MODI_FORCING -USE MODI_FORC_SQUALL_LINE -USE MODI_FORC_WIND -USE MODI_GET_HALO -USE MODI_GRAVITY_IMPL -USE MODI_IBM_INIT -USE MODI_IBM_FORCING -USE MODI_IBM_FORCING_TR -USE MODI_IBM_FORCING_ADV -USE MODI_INI_DIAG_IN_RUN -USE MODI_INI_LG -USE MODI_INI_MEAN_FIELD -USE MODI_INITIAL_GUESS -USE MODI_LES_INI_TIMESTEP_n -USE MODI_LES_N -USE MODI_LIMA_PRECIP_SCAVENGING -USE MODI_LS_COUPLING -USE MODI_MASK_COMPRESS -USE MODI_MEAN_FIELD -USE MODI_MNHGET_SURF_PARAM_n -USE MODI_MNHWRITE_ZS_DUMMY_n -USE MODI_NUDGING -USE MODI_NUM_DIFF -USE MODI_PHYS_PARAM_n -USE MODI_PRESSUREZ -USE MODI_PROFILER_n -USE MODI_RAD_BOUND -USE MODI_RECYCLING -USE MODI_RELAX2FW_ION -USE MODI_RELAXATION -USE MODI_REL_FORCING_n -USE MODI_RESOLVED_CLOUD -USE MODI_RESOLVED_ELEC_n -USE MODI_SERIES_N -USE MODI_SETLB_LG -USE MODI_SET_MASK -USE MODI_SHUMAN -USE MODI_SPAWN_LS_n -USE MODI_STATION_n -USE MODI_TURB_CLOUD_INDEX -USE MODI_TWO_WAY -USE MODI_UPDATE_NSV -USE MODI_VISCOSITY -USE MODI_WRITE_AIRCRAFT_BALLOON -USE MODI_WRITE_DESFM_n -USE MODI_WRITE_DIAG_SURF_ATM_N -USE MODI_WRITE_LFIFM_n -USE MODI_WRITE_SERIES_n -USE MODI_WRITE_STATION_n -USE MODI_WRITE_SURF_ATM_N -#ifdef MNH_BITREP_OMP -USE MODI_BITREPZ -#endif -! -IMPLICIT NONE -! -!* 0.1 declarations of arguments -! -! -! -INTEGER, INTENT(IN) :: KTCOUNT -LOGICAL, INTENT(INOUT):: OEXIT -! -!* 0.2 declarations of local variables -! -INTEGER :: ILUOUT ! Logical unit number for the output listing -INTEGER :: IIU,IJU,IKU ! array size in first, second and third dimensions -INTEGER :: IIB,IIE,IJB,IJE ! index values for the physical subdomain -INTEGER :: JSV,JRR ! Loop index for scalar and moist variables -INTEGER :: INBVAR ! number of HALO2_lls to allocate -INTEGER :: IINFO_ll ! return code of parallel routine -INTEGER :: IVERB ! LFI verbosity level -LOGICAL :: GSTEADY_DMASS ! conditional call to mass computation -! - ! for computing time analysis -REAL(kind=MNHTIME), DIMENSION(2) :: ZTIME, ZTIME1, ZTIME2, ZEND, ZTOT, ZALL, ZTOT_PT -REAL(kind=MNHTIME), DIMENSION(2) :: ZTIME_STEP,ZTIME_STEP_PTS -CHARACTER :: YMI -INTEGER :: IPOINTS -CHARACTER(len=16) :: YTCOUNT,YPOINTS -! -INTEGER :: ISYNCHRO ! model synchronic index relative to its father - ! = 1 for the first time step in phase with DAD - ! = 0 for the last time step (out of phase) -INTEGER :: IMI ! Current model index -REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZSEA -REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZTOWN -! Dummy pointers needed to correct an ifort Bug -REAL, DIMENSION(:), POINTER :: DPTR_XZHAT -REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4 -REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4 -REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4 -REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4 -CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY -INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV -INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM -REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM -REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS -REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSM,DPTR_XLSZWSS -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUS,DPTR_XLBYUS,DPTR_XLBXVS,DPTR_XLBYVS -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWS,DPTR_XLBYWS,DPTR_XLBXTHS,DPTR_XLBYTHS -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKES,DPTR_XLBYTKES -REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRS,DPTR_XLBYRS,DPTR_XLBXSVS,DPTR_XLBYSVS -! -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XRHODJ,DPTR_XUM,DPTR_XVM,DPTR_XWM,DPTR_XTHM -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XTKEM,DPTR_XRUS,DPTR_XRVS,DPTR_XRWS,DPTR_XRTHS -REAL, DIMENSION(:,:,:), POINTER :: DPTR_XRTKES,DPTR_XDIRFLASWD,DPTR_XSCAFLASWD,DPTR_XDIRSRFSWD -REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XRM,DPTR_XSVM,DPTR_XRRS,DPTR_XRSVS -REAL, DIMENSION(:,:), POINTER :: DPTR_XINPRC,DPTR_XINPRR,DPTR_XINPRS,DPTR_XINPRG -REAL, DIMENSION(:,:), POINTER :: DPTR_XINPRH,DPTR_XPRCONV,DPTR_XPRSCONV -LOGICAL, DIMENSION(:,:),POINTER :: DPTR_GMASKkids -! -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDC -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDR -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDS -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDG -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDH -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRC3D -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRS3D -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRG3D -! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRH3D -! -LOGICAL :: KWARM -LOGICAL :: KRAIN -LOGICAL :: KSEDC -LOGICAL :: KACTIT -LOGICAL :: KSEDI -LOGICAL :: KHHONI -! -#ifndef MNH_OPENACC -REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRUS,ZRVS -REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRWS -REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZPABST !To give pressure at t - ! (and not t+1) to resolved_cloud -#else -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRUS,ZRVS -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRWS -REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPABST !To give pressure at t - ! (and not t+1) to resolved_cloud -#endif -REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ -! -TYPE(LIST_ll), POINTER :: TZFIELDC_ll ! list of fields to exchange -TYPE(HALO2LIST_ll), POINTER :: TZHALO2C_ll ! list of fields to exchange -#ifdef MNH_OPENACC -TYPE(HALO2LIST_ll), SAVE , POINTER :: TZHALO2_UT,TZHALO2_VT,TZHALO2_WT -LOGICAL , SAVE :: GFIRST_CALL_MODELN = .TRUE. -#endif -LOGICAL :: GCLD ! conditionnal call for dust wet deposition -LOGICAL :: GCLOUD_ONLY ! conditionnal radiation computations for - ! the only cloudy columns -REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZWETDEPAER - - -! -TYPE(TFILEDATA),POINTER :: TZBAKFILE, TZOUTFILE -! TYPE(TFILEDATA),SAVE :: TZDIACFILE -! -#ifdef MNH_COMPILER_CCE -!Bypass cray bug with scalar pointer -REAL :: VSIGQSAT -VSIGQSAT = VSIGQSAT_MODD -#endif -!------------------------------------------------------------------------------- - -TZBAKFILE=> NULL() -TZOUTFILE=> NULL() - -#ifndef MNH_OPENACC -allocate( ZRUS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) ) -allocate( ZRVS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) ) -allocate( ZRWS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) ) -allocate( ZPABST(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) ) -#else -!Pin positions in the pools of MNH memory -CALL MNH_MEM_POSITION_PIN() -CALL MNH_MEM_GET( ZRUS, SIZE( XTHT, 1 ), SIZE( XTHT, 2 ), SIZE( XTHT, 3 ) ) -CALL MNH_MEM_GET( ZRVS, SIZE( XTHT, 1 ), SIZE( XTHT, 2 ), SIZE( XTHT, 3 ) ) -CALL MNH_MEM_GET( ZRWS, SIZE( XTHT, 1 ), SIZE( XTHT, 2 ), SIZE( XTHT, 3 ) ) -CALL MNH_MEM_GET( ZPABST, SIZE( XTHT, 1 ), SIZE( XTHT, 2 ), SIZE( XTHT, 3 ) ) -#endif -allocate( ZJ (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) ) -allocate( ZWETDEPAER(SIZE(XRSVS,1), SIZE(XRSVS,2), SIZE(XRSVS,3), NSV_AER) ) -! -!* 0. MICROPHYSICAL SCHEME -! ------------------- -SELECT CASE(CCLOUD) -CASE('C2R2','KHKO','C3R5') - KWARM = .TRUE. - KRAIN = NRAIN - KSEDC = NSEDC - KACTIT = NACTIT -! - KSEDI = NSEDI - KHHONI = NHHONI -CASE('LIMA') - KWARM = MWARM - KRAIN = MRAIN - KSEDC = MSEDC - KACTIT = MACTIT -! - KSEDI = MSEDI - KHHONI = MHHONI -CASE('ICE3','ICE4') !default values - KWARM = LWARM - KRAIN = .TRUE. - KSEDC = .TRUE. - KACTIT = .FALSE. -! - KSEDI = .TRUE. - KHHONI = .FALSE. -END SELECT -! -! -!* 1 PRELIMINARY -! ------------ -IMI = GET_CURRENT_MODEL_INDEX() -! -!* 1.0 update NSV_* variables for current model -! ---------------------------------------- -! -CALL UPDATE_NSV(IMI) -! -!* 1.1 RECOVER THE LOGICAL UNIT NUMBER FOR THE OUTPUT PRINTS -! -ILUOUT = TLUOUT%NLU -! -!* 1.2 SET ARRAY SIZE -! -CALL GET_DIM_EXT_ll('B',IIU,IJU) -IKU=NKMAX+2*JPVEXT -CALL GET_INDICE_ll (IIB,IJB,IIE,IJE) -! -IF (IMI==1) THEN - GSTEADY_DMASS=LSTEADYLS -ELSE - GSTEADY_DMASS=.FALSE. -END IF -! -!* 1.3 OPEN THE DIACHRONIC FILE -! -IF (KTCOUNT == 1) THEN -! - NULLIFY(TFIELDS_ll,TLSFIELD_ll,TFIELDT_ll) - NULLIFY(TLSFIELD2D_ll) - NULLIFY(THALO2T_ll) - NULLIFY(TLSHALO2_ll) - NULLIFY(TFIELDSC_ll) -! - ALLOCATE(XWT_ACT_NUC(SIZE(XWT,1),SIZE(XWT,2),SIZE(XWT,3))) - ALLOCATE(GMASKkids(SIZE(XWT,1),SIZE(XWT,2))) -! - IF ( .NOT. LIO_NO_WRITE ) THEN - CALL IO_File_open(TDIAFILE) -! - CALL IO_Header_write(TDIAFILE) - CALL WRITE_DESFM_n(IMI,TDIAFILE) - CALL WRITE_LFIFMN_FORDIACHRO_n(TDIAFILE) - END IF -! -!* 1.4 Initialization of the list of fields for the halo updates -! -! a) Sources terms -! - CALL ADD3DFIELD_ll( TFIELDS_ll, XRUS, 'MODEL_n::XRUS' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRVS, 'MODEL_n::XRVS' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRWS, 'MODEL_n::XRWS' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRTHS, 'MODEL_n::XRTHS' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRUS_PRES, 'MODEL_n::XRUS_PRES' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRVS_PRES, 'MODEL_n::XRVS_PRES' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRWS_PRES, 'MODEL_n::XRWS_PRES' ) - CALL ADD3DFIELD_ll( TFIELDS_ll, XRTHS_CLD, 'MODEL_n::XRTHS_CLD' ) - IF (SIZE(XRTKES,1) /= 0) CALL ADD3DFIELD_ll( TFIELDS_ll, XRTKES, 'MODEL_n::XRTKES' ) - CALL ADD4DFIELD_ll( TFIELDS_ll, XRRS (:,:,:,1:NRR), 'MODEL_n::XRRS' ) - CALL ADD4DFIELD_ll( TFIELDS_ll, XRRS_CLD (:,:,:,1:NRR), 'MODEL_n::XRRS_CLD' ) - CALL ADD4DFIELD_ll( TFIELDS_ll, XRSVS (:,:,:,1:NSV), 'MODEL_n::XRSVS') - CALL ADD4DFIELD_ll( TFIELDS_ll, XRSVS_CLD(:,:,:,1:NSV), 'MODEL_n::XRSVS_CLD') - IF (SIZE(XSRCT,1) /= 0) CALL ADD3DFIELD_ll( TFIELDS_ll, XSRCT, 'MODEL_n::XSRCT' ) - ! - IF ((LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV) ) THEN - ! - ! b) LS fields - ! - CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSUM, 'MODEL_n::XLSUM' ) - CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSVM, 'MODEL_n::XLSVM' ) - CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSWM, 'MODEL_n::XLSWM' ) - CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSTHM, 'MODEL_n::XLSTHM' ) - CALL ADD2DFIELD_ll( TLSFIELD2D_ll, XLSZWSM, 'MODEL_n::XLSZWSM' ) - IF (NRR >= 1) THEN - CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSRVM, 'MODEL_n::XLSRVM' ) - ENDIF - ! - ! c) Fields at t - ! - CALL ADD3DFIELD_ll( TFIELDT_ll, XUT, 'MODEL_n::XUT' ) - CALL ADD3DFIELD_ll( TFIELDT_ll, XVT, 'MODEL_n::XVT' ) - CALL ADD3DFIELD_ll( TFIELDT_ll, XWT, 'MODEL_n::XWT' ) - CALL ADD3DFIELD_ll( TFIELDT_ll, XTHT, 'MODEL_n::XTHT' ) - IF (SIZE(XRTKES,1) /= 0) CALL ADD3DFIELD_ll( TFIELDT_ll, XTKET, 'MODEL_n::XTKET' ) - CALL ADD4DFIELD_ll(TFIELDT_ll, XRT (:,:,:,1:NRR), 'MODEL_n::XSV' ) - CALL ADD4DFIELD_ll(TFIELDT_ll, XSVT(:,:,:,1:NSV), 'MODEL_n::XSVT' ) - ! - !* 1.5 Initialize the list of fields for the halo updates (2nd layer) - ! - INBVAR = 4+NRR+NSV - IF (SIZE(XRTKES,1) /= 0) INBVAR=INBVAR+1 - CALL INIT_HALO2_ll(THALO2T_ll,INBVAR,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TLSHALO2_ll,4+MIN(1,NRR),IIU,IJU,IKU) - ! - !* 1.6 Initialise the 2nd layer of the halo of the LS fields - ! - IF ( LSTEADYLS ) THEN - CALL UPDATE_HALO_ll(TLSFIELD_ll, IINFO_ll) - CALL UPDATE_HALO_ll(TLSFIELD2D_ll,IINFO_ll) - CALL UPDATE_HALO2_ll(TLSFIELD_ll, TLSHALO2_ll, IINFO_ll) - END IF - END IF - ! -! - ! - XT_START = 0.0_MNHTIME - ! - XT_STORE = 0.0_MNHTIME - XT_BOUND = 0.0_MNHTIME - XT_GUESS = 0.0_MNHTIME - XT_FORCING = 0.0_MNHTIME - XT_NUDGING = 0.0_MNHTIME - XT_ADV = 0.0_MNHTIME - XT_ADVUVW = 0.0_MNHTIME - XT_GRAV = 0.0_MNHTIME - XT_SOURCES = 0.0_MNHTIME - ! - XT_DIFF = 0.0_MNHTIME - XT_RELAX = 0.0_MNHTIME - XT_PARAM = 0.0_MNHTIME - XT_SPECTRA = 0.0_MNHTIME - XT_HALO = 0.0_MNHTIME - XT_VISC = 0.0_MNHTIME - XT_RAD_BOUND = 0.0_MNHTIME - XT_PRESS = 0.0_MNHTIME - ! - XT_CLOUD = 0.0_MNHTIME - XT_STEP_SWA = 0.0_MNHTIME - XT_STEP_MISC = 0.0_MNHTIME - XT_COUPL = 0.0_MNHTIME - XT_1WAY = 0.0_MNHTIME - XT_STEP_BUD = 0.0_MNHTIME - ! - XT_RAD = 0.0_MNHTIME - XT_DCONV = 0.0_MNHTIME - XT_GROUND = 0.0_MNHTIME - XT_TURB = 0.0_MNHTIME - XT_MAFL = 0.0_MNHTIME - XT_DRAG = 0.0_MNHTIME - XT_EOL = 0.0_MNHTIME - XT_TRACER = 0.0_MNHTIME - XT_SHADOWS = 0.0_MNHTIME - XT_ELEC = 0.0_MNHTIME - XT_CHEM = 0.0_MNHTIME - XT_2WAY = 0.0_MNHTIME - ! - XT_IBM_FORC = 0.0_MNHTIME - ! -END IF -! -!* 1.7 Allocation of arrays for observation diagnostics -! -CALL INI_DIAG_IN_RUN(IIU,IJU,IKU,LFLYER,LSTATION,LPROFILER) -! -! -CALL SECOND_MNH2(ZEND) -! -!------------------------------------------------------------------------------- -! -!* 2. ONE-WAY NESTING AND LARGE SCALE FIELD REFRESH -! --------------------------------------------- -! -! -CALL SECOND_MNH2(ZTIME1) -! -ISYNCHRO = MODULO (KTCOUNT, NDTRATIO(IMI) ) ! test of synchronisation -! -! -IF (LCOUPLES.AND.LOCEAN) THEN - CALL NHOA_COUPL_n(NDAD(IMI),XTSTEP,IMI,KTCOUNT,IKU) -END IF -! No Gridnest in coupled OA LES for now -IF (.NOT. LCOUPLES .AND. IMI/=1 .AND. NDAD(IMI)/=IMI .AND. (ISYNCHRO==1 .OR. NDTRATIO(IMI) == 1) ) THEN -! -! Use dummy pointers to correct an ifort BUG - DPTR_XBMX1=>XBMX1 - DPTR_XBMX2=>XBMX2 - DPTR_XBMX3=>XBMX3 - DPTR_XBMX4=>XBMX4 - DPTR_XBMY1=>XBMY1 - DPTR_XBMY2=>XBMY2 - DPTR_XBMY3=>XBMY3 - DPTR_XBMY4=>XBMY4 - DPTR_XBFX1=>XBFX1 - DPTR_XBFX2=>XBFX2 - DPTR_XBFX3=>XBFX3 - DPTR_XBFX4=>XBFX4 - DPTR_XBFY1=>XBFY1 - DPTR_XBFY2=>XBFY2 - DPTR_XBFY3=>XBFY3 - DPTR_XBFY4=>XBFY4 - DPTR_CLBCX=>CLBCX - DPTR_CLBCY=>CLBCY - ! - DPTR_XZZ=>XZZ - DPTR_XZHAT=>XZHAT - DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM - DPTR_XLSTHM=>XLSTHM - DPTR_XLSRVM=>XLSRVM - DPTR_XLSUM=>XLSUM - DPTR_XLSVM=>XLSVM - DPTR_XLSWM=>XLSWM - DPTR_XLSZWSM=>XLSZWSM - DPTR_XLSTHS=>XLSTHS - DPTR_XLSRVS=>XLSRVS - DPTR_XLSUS=>XLSUS - DPTR_XLSVS=>XLSVS - DPTR_XLSWS=>XLSWS - DPTR_XLSZWSS=>XLSZWSS - ! - IF ( LSTEADYLS ) THEN - NCPL_CUR=0 - ELSE - IF (NCPL_CUR/=1) THEN - IF ( KTCOUNT+1 == NCPL_TIMES(NCPL_CUR-1,IMI) ) THEN - ! - ! LS sources are interpolated from the LS field - ! values of model DAD(IMI) - CALL SPAWN_LS_n(NDAD(IMI),XTSTEP,IMI, & - DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, & - DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, & - NDXRATIO_ALL(IMI),NDYRATIO_ALL(IMI), & - DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT,LSLEVE,XLEN1,XLEN2,DPTR_XCOEFLIN_LBXM, & - DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSZWSM, & - DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS, DPTR_XLSZWSS ) - END IF - END IF - ! - END IF - ! - DPTR_NKLIN_LBXU=>NKLIN_LBXU - DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU - DPTR_NKLIN_LBYU=>NKLIN_LBYU - DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU - DPTR_NKLIN_LBXV=>NKLIN_LBXV - DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV - DPTR_NKLIN_LBYV=>NKLIN_LBYV - DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV - DPTR_NKLIN_LBXW=>NKLIN_LBXW - DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW - DPTR_NKLIN_LBYW=>NKLIN_LBYW - DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW - ! - DPTR_NKLIN_LBXM=>NKLIN_LBXM - DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM - DPTR_NKLIN_LBYM=>NKLIN_LBYM - DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM - ! - DPTR_XLBXUM=>XLBXUM - DPTR_XLBYUM=>XLBYUM - DPTR_XLBXVM=>XLBXVM - DPTR_XLBYVM=>XLBYVM - DPTR_XLBXWM=>XLBXWM - DPTR_XLBYWM=>XLBYWM - DPTR_XLBXTHM=>XLBXTHM - DPTR_XLBYTHM=>XLBYTHM - DPTR_XLBXTKEM=>XLBXTKEM - DPTR_XLBYTKEM=>XLBYTKEM - DPTR_XLBXRM=>XLBXRM - DPTR_XLBYRM=>XLBYRM - DPTR_XLBXSVM=>XLBXSVM - DPTR_XLBYSVM=>XLBYSVM - ! - DPTR_XLBXUS=>XLBXUS - DPTR_XLBYUS=>XLBYUS - DPTR_XLBXVS=>XLBXVS - DPTR_XLBYVS=>XLBYVS - DPTR_XLBXWS=>XLBXWS - DPTR_XLBYWS=>XLBYWS - DPTR_XLBXTHS=>XLBXTHS - DPTR_XLBYTHS=>XLBYTHS - DPTR_XLBXTKES=>XLBXTKES - DPTR_XLBYTKES=>XLBYTKES - DPTR_XLBXRS=>XLBXRS - DPTR_XLBYRS=>XLBYRS - DPTR_XLBXSVS=>XLBXSVS - DPTR_XLBYSVS=>XLBYSVS - ! - CALL ONE_WAY_n(NDAD(IMI),XTSTEP,IMI,KTCOUNT, & - DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, & - DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, & - NDXRATIO_ALL(IMI),NDYRATIO_ALL(IMI),NDTRATIO(IMI), & - DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, & - DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, & - DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, & - DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, & - DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, & - GSTEADY_DMASS,CCLOUD,LUSECHAQ,LUSECHIC, & - DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, & - DPTR_XLBXTHM,DPTR_XLBYTHM, & - DPTR_XLBXTKEM,DPTR_XLBYTKEM, & - DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM, & - XDRYMASST,XDRYMASSS, & - DPTR_XLBXUS,DPTR_XLBYUS,DPTR_XLBXVS,DPTR_XLBYVS,DPTR_XLBXWS,DPTR_XLBYWS, & - DPTR_XLBXTHS,DPTR_XLBYTHS, & - DPTR_XLBXTKES,DPTR_XLBYTKES, & - DPTR_XLBXRS,DPTR_XLBYRS,DPTR_XLBXSVS,DPTR_XLBYSVS ) - ! -END IF -! -CALL SECOND_MNH2(ZTIME2) -XT_1WAY = XT_1WAY + ZTIME2 - ZTIME1 -! -!* 2.1 RECYCLING TURBULENCE -! ---- -IF (CTURB /= 'NONE' .AND. LRECYCL) THEN - CALL RECYCLING(XFLUCTUNW,XFLUCTVNN,XFLUCTUTN,XFLUCTVTW,XFLUCTWTW,XFLUCTWTN, & - XFLUCTUNE,XFLUCTVNS,XFLUCTUTS,XFLUCTVTE,XFLUCTWTE,XFLUCTWTS, & - KTCOUNT) -ENDIF -! -!* 2.2 IBM -! ---- -! -IF (LIBM .AND. KTCOUNT==1) THEN - ! - IF (.NOT.LCARTESIAN) THEN - CALL PRINT_MSG(NVERB_FATAL, 'GEN', 'MODELN', 'IBM can only be used in combination with cartesian coordinates') - ENDIF - ! - CALL IBM_INIT(XIBM_LS) - ! -ENDIF -! -!------------------------------------------------------------------------------- -! -!* 3. LATERAL BOUNDARY CONDITIONS EXCEPT FOR NORMAL VELOCITY -! ------------------------------------------------------ -! -ZTIME1=ZTIME2 -! -!* 3.1 Set the lagragian variables values at the LB -! -IF( LLG .AND. IMI==1 ) CALL SETLB_LG -! -IF (CCONF == "START" .OR. (CCONF == "RESTA" .AND. KTCOUNT /= 1 )) THEN -CALL BOUNDARIES ( & - XTSTEP,CLBCX,CLBCY,NRR,NSV,KTCOUNT, & - XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, & - XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, & - XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, & - XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS, & - XRHODJ,XRHODREF, & - XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, XSRCT ) -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_BOUND = XT_BOUND + ZTIME2 - ZTIME1 -! -! -! For START/RESTART MPPDB_CHECK use -!IF ( (IMI==1) .AND. (CCONF == "START") .AND. (KTCOUNT == 2) ) THEN -! CALL MPPDB_START_DEBUG() -!ENDIF -!IF ( (IMI==1) .AND. (CCONF == "RESTA") .AND. (KTCOUNT == 1) ) THEN -! CALL MPPDB_START_DEBUG() -!ENDIF -!------------------------------------------------------------------------------- -!* initializes surface number -IF (CSURF=='EXTE') CALL GOTO_SURFEX(IMI) -!------------------------------------------------------------------------------- -! -!* 4. STORAGE IN A SYNCHRONOUS FILE -! ----------------------------- -! -ZTIME1 = ZTIME2 -! -IF ( nfile_backup_current < NBAK_NUMB ) THEN - IF ( KTCOUNT == TBACKUPN(nfile_backup_current + 1)%NSTEP ) THEN - nfile_backup_current = nfile_backup_current + 1 - ! - TZBAKFILE => TBACKUPN(nfile_backup_current)%TFILE - IVERB = TZBAKFILE%NLFIVERB - ! - CALL IO_File_open(TZBAKFILE) - ! - CALL WRITE_DESFM_n(IMI,TZBAKFILE) - CALL IO_Header_write( TBACKUPN(nfile_backup_current)%TFILE ) - CALL WRITE_LFIFM_n( TBACKUPN(nfile_backup_current)%TFILE, TBACKUPN(nfile_backup_current)%TFILE%TDADFILE%CNAME ) - TOUTDATAFILE => TZBAKFILE - CALL MNHWRITE_ZS_DUMMY_n(TZBAKFILE) - IF (CSURF=='EXTE') THEN - TFILE_SURFEX => TZBAKFILE - CALL GOTO_SURFEX(IMI) - CALL WRITE_SURF_ATM_n(YSURF_CUR,'MESONH','ALL',.FALSE.) - IF ( KTCOUNT > 1) THEN - CALL DIAG_SURF_ATM_n(YSURF_CUR,'MESONH') - CALL WRITE_DIAG_SURF_ATM_n(YSURF_CUR,'MESONH','ALL') - END IF - NULLIFY(TFILE_SURFEX) - END IF - ! - ! Reinitialize Lagragian variables at every model backup - IF (LLG .AND. LINIT_LG .AND. CINIT_LG=='FMOUT') THEN - CALL INI_LG(XXHAT,XYHAT,XZZ,XSVT,XLBXSVM,XLBYSVM) - IF (IVERB>=5) THEN - WRITE(UNIT=ILUOUT,FMT=*) '************************************' - WRITE(UNIT=ILUOUT,FMT=*) '*** Lagrangian variables refreshed after ',TRIM(TZBAKFILE%CNAME),' backup' - WRITE(UNIT=ILUOUT,FMT=*) '************************************' - END IF - END IF - ! Reinitialise mean variables - IF (LMEAN_FIELD) THEN - CALL INI_MEAN_FIELD - END IF -! - ELSE - !Necessary to have a 'valid' CNAME when calling some subroutines - TZBAKFILE => TFILE_DUMMY - END IF -ELSE - !Necessary to have a 'valid' CNAME when calling some subroutines - TZBAKFILE => TFILE_DUMMY -END IF -! -IF ( nfile_output_current < NOUT_NUMB ) THEN - IF ( KTCOUNT == TOUTPUTN(nfile_output_current + 1)%NSTEP ) THEN - nfile_output_current = nfile_output_current + 1 - ! - TZOUTFILE => TOUTPUTN(nfile_output_current)%TFILE - ! - CALL IO_File_open(TZOUTFILE) - ! - CALL IO_Header_write(TZOUTFILE) - CALL IO_Fieldlist_write( TOUTPUTN(nfile_output_current) ) - CALL IO_Field_user_write( TOUTPUTN(nfile_output_current) ) - ! - CALL IO_File_close(TZOUTFILE) - ! - END IF -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_STORE = XT_STORE + ZTIME2 - ZTIME1 -! -!------------------------------------------------------------------------------- -! -!* 4.BIS IBM and Fluctuations application -! ----------------------------- -! -!* 4.B1 Add fluctuations at the domain boundaries -! -IF (LRECYCL) THEN - CALL ADDFLUCTUATIONS ( & - CLBCX,CLBCY, & - XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, XSRCT, & - XFLUCTUTN,XFLUCTVTW,XFLUCTUTS,XFLUCTVTE, & - XFLUCTWTW,XFLUCTWTN,XFLUCTWTS,XFLUCTWTE ) -ENDIF -! -!* 4.B2 Immersed boundaries -! -IF (LIBM) THEN - ! - ZTIME1=ZTIME2 - ! - IF (.NOT.LCARTESIAN) THEN - CALL PRINT_MSG(NVERB_FATAL, 'GEN', 'MODELN', 'IBM can only be used in combination with cartesian coordinates') - ENDIF - ! - CALL IBM_FORCING(XUT,XVT,XWT,XTHT,XRT,XSVT,XTKET) - ! - IF (LIBM_TROUBLE) THEN - CALL IBM_FORCING_TR(XUT,XVT,XWT,XTHT,XRT,XSVT,XTKET) - ENDIF - ! - CALL SECOND_MNH2(ZTIME2) - ! - XT_IBM_FORC = XT_IBM_FORC + ZTIME2 - ZTIME1 - ! -ENDIF -!------------------------------------------------------------------------------- -! -!* 5. INITIALIZATION OF THE BUDGET VARIABLES -! -------------------------------------- -! -IF (NBUMOD==IMI) THEN - LBU_ENABLE = CBUTYPE /='NONE'.AND. CBUTYPE /='SKIP' -ELSE - LBU_ENABLE = .FALSE. -END IF -! -IF (NBUMOD==IMI .AND. CBUTYPE=='MASK' ) THEN - CALL SET_MASK() - if ( lbu_ru ) then - tbudgets(NBUDGET_U)%trhodj%xdata(:, nbutime, :) = tbudgets(NBUDGET_U)%trhodj%xdata(:, nbutime, :) & - + Mask_compress( Mxm( xrhodj(:, :, :) ) ) - end if - if ( lbu_rv ) then - tbudgets(NBUDGET_V)%trhodj%xdata(:, nbutime, :) = tbudgets(NBUDGET_V)%trhodj%xdata(:, nbutime, :) & - + Mask_compress( Mym( xrhodj(:, :, :) ) ) - end if - if ( lbu_rw ) then - tbudgets(NBUDGET_W)%trhodj%xdata(:, nbutime, :) = tbudgets(NBUDGET_W)%trhodj%xdata(:, nbutime, :) & - + Mask_compress( Mzm( xrhodj(:, :, :) ) ) - end if - if ( associated( tburhodj ) ) tburhodj%xdata(:, nbutime, :) = tburhodj%xdata(:, nbutime, :) + Mask_compress( xrhodj(:, :, :) ) -END IF -! -IF (NBUMOD==IMI .AND. CBUTYPE=='CART' ) THEN - if ( lbu_ru ) then - tbudgets(NBUDGET_U)%trhodj%xdata(:, :, :) = tbudgets(NBUDGET_U)%trhodj%xdata(:, :, :) + Cart_compress( Mxm( xrhodj(:, :, :) ) ) - end if - if ( lbu_rv ) then - tbudgets(NBUDGET_V)%trhodj%xdata(:, :, :) = tbudgets(NBUDGET_V)%trhodj%xdata(:, :, :) + Cart_compress( Mym( xrhodj(:, :, :) ) ) - end if - if ( lbu_rw ) then - tbudgets(NBUDGET_W)%trhodj%xdata(:, :, :) = tbudgets(NBUDGET_W)%trhodj%xdata(:, :, :) & - + Cart_compress( Mzm( xrhodj(:, :, :) ) ) - end if - if ( associated( tburhodj ) ) tburhodj%xdata(:, :, :) = tburhodj%xdata(:, :, :) + Cart_compress( xrhodj(:, :, :) ) -END IF -! -CALL BUDGET_FLAGS(LUSERV, LUSERC, LUSERR, & - LUSERI, LUSERS, LUSERG, LUSERH ) -! -XTIME_BU = 0.0 -! -!------------------------------------------------------------------------------- -! -!* 6. INITIALIZATION OF THE FIELD TENDENCIES -! -------------------------------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -! -CALL INITIAL_GUESS ( NRR, NSV, KTCOUNT, XRHODJ,IMI, XTSTEP, & - XRUS, XRVS, XRWS, XRTHS, XRRS, XRTKES, XRSVS, & - XUT, XVT, XWT, XTHT, XRT, XTKET, XSVT ) -! -CALL SECOND_MNH2(ZTIME2) -! -XT_GUESS = XT_GUESS + ZTIME2 - ZTIME1 - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 7. INITIALIZATION OF THE LES FOR CURRENT TIME-STEP -! ----------------------------------------------- -! -XTIME_LES_BU = 0.0 -XTIME_LES = 0.0 -IF (LLES) CALL LES_INI_TIMESTEP_n(KTCOUNT) -! -!------------------------------------------------------------------------------- -! -!* 8. TWO-WAY INTERACTIVE GRID-NESTING -! -------------------------------- -! -! -CALL SECOND_MNH2(ZTIME1) -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -GMASKkids(:,:)=.FALSE. -! -IF (NMODEL>1) THEN - ! correct an ifort bug - DPTR_XRHODJ=>XRHODJ - DPTR_XUM=>XUT - DPTR_XVM=>XVT - DPTR_XWM=>XWT - DPTR_XTHM=>XTHT - DPTR_XRM=>XRT - DPTR_XTKEM=>XTKET - DPTR_XSVM=>XSVT - DPTR_XRUS=>XRUS - DPTR_XRVS=>XRVS - DPTR_XRWS=>XRWS - DPTR_XRTHS=>XRTHS - DPTR_XRRS=>XRRS - DPTR_XRTKES=>XRTKES - DPTR_XRSVS=>XRSVS - DPTR_XINPRC=>XINPRC - DPTR_XINPRR=>XINPRR - DPTR_XINPRS=>XINPRS - DPTR_XINPRG=>XINPRG - DPTR_XINPRH=>XINPRH - DPTR_XPRCONV=>XPRCONV - DPTR_XPRSCONV=>XPRSCONV - DPTR_XDIRFLASWD=>XDIRFLASWD - DPTR_XSCAFLASWD=>XSCAFLASWD - DPTR_XDIRSRFSWD=>XDIRSRFSWD - DPTR_GMASKkids=>GMASKkids - ! - CALL TWO_WAY( NRR,NSV,KTCOUNT,DPTR_XRHODJ,IMI,XTSTEP, & - DPTR_XUM ,DPTR_XVM ,DPTR_XWM , DPTR_XTHM, DPTR_XRM,DPTR_XSVM, & - DPTR_XRUS,DPTR_XRVS,DPTR_XRWS,DPTR_XRTHS,DPTR_XRRS,DPTR_XRSVS, & - DPTR_XINPRC,DPTR_XINPRR,DPTR_XINPRS,DPTR_XINPRG,DPTR_XINPRH,DPTR_XPRCONV,DPTR_XPRSCONV, & - DPTR_XDIRFLASWD,DPTR_XSCAFLASWD,DPTR_XDIRSRFSWD,DPTR_GMASKkids ) -END IF -! -CALL SECOND_MNH2(ZTIME2) -XT_2WAY = XT_2WAY + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- -! -!* 10. FORCING -! ------- -! -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -IF (LCARTESIAN) THEN - CALL SM_GRIDCART(XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XDXHAT,XDYHAT,XZZ,ZJ) - XMAP=1. -ELSE - CALL SM_GRIDPROJ(XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XLATORI,XLONORI, & - XMAP,XLAT,XLON,XDXHAT,XDYHAT,XZZ,ZJ) -END IF -! -IF ( LFORCING ) THEN - CALL FORCING(XTSTEP,LUSERV,XRHODJ,XCORIOZ,XZHAT,XZZ,TDTCUR,& - XUFRC_PAST, XVFRC_PAST,XWTFRC, & - XUT,XVT,XWT,XTHT,XTKET,XRT,XSVT, & - XRUS,XRVS,XRWS,XRTHS,XRTKES,XRRS,XRSVS,IMI,ZJ) -END IF -! -IF ( L2D_ADV_FRC ) THEN - CALL ADV_FORCING_n(XRHODJ,TDTCUR,XTHT,XRT,XZZ,XRTHS,XRRS) -END IF -IF ( L2D_REL_FRC ) THEN - CALL REL_FORCING_n(XRHODJ,TDTCUR,XTHT,XRT,XZZ,XRTHS,XRRS) -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_FORCING = XT_FORCING + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 11. NUDGING -! ------- -! -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF ( LNUDGING ) THEN - CALL NUDGING(LUSERV,XRHODJ,XTNUDGING, & - XUT,XVT,XWT,XTHT,XRT, & - XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM, & - XRUS,XRVS,XRWS,XRTHS,XRRS) - -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_NUDGING = XT_NUDGING + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 12. DYNAMICAL SOURCES -! ----------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF( LTRANS ) THEN - XUT(:,:,:) = XUT(:,:,:) + XUTRANS - XVT(:,:,:) = XVT(:,:,:) + XVTRANS -END IF -! -CALL DYN_SOURCES( NRR,NRRL, NRRI, & - XUT, XVT, XWT, XTHT, XRT, & - XCORIOX, XCORIOY, XCORIOZ, XCURVX, XCURVY, & - XRHODJ, XZZ, XTHVREF, XEXNREF, & - XRUS, XRVS, XRWS, XRTHS ) -! -IF( LTRANS ) THEN - XUT(:,:,:) = XUT(:,:,:) - XUTRANS - XVT(:,:,:) = XVT(:,:,:) - XVTRANS -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_SOURCES = XT_SOURCES + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 13. NUMERICAL DIFFUSION -! ------------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF ( LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV ) THEN -! - CALL UPDATE_HALO_ll(TFIELDT_ll, IINFO_ll) - CALL UPDATE_HALO2_ll(TFIELDT_ll, THALO2T_ll, IINFO_ll) - IF ( .NOT. LSTEADYLS ) THEN - CALL UPDATE_HALO_ll(TLSFIELD_ll, IINFO_ll) - CALL UPDATE_HALO_ll(TLSFIELD2D_ll,IINFO_ll) - CALL UPDATE_HALO2_ll(TLSFIELD_ll, TLSHALO2_ll, IINFO_ll) - END IF - CALL NUM_DIFF ( CLBCX, CLBCY, NRR, NSV, & - XDK2U, XDK4U, XDK2TH, XDK4TH, XDK2SV, XDK4SV, IMI, & - XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, & - XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XRHODJ, & - XRUS, XRVS, XRWS, XRTHS, XRTKES, XRRS, XRSVS, & - LZDIFFU,LNUMDIFU, LNUMDIFTH, LNUMDIFSV, & - THALO2T_ll, TLSHALO2_ll,XZDIFFU_HALO2 ) -END IF - -if ( lbudget_sv ) then - do jsv = 1, nsv - call Budget_store_init( tbudgets(jsv + NBUDGET_SV1 - 1), 'NEGA2', xrsvs(:, :, :, jsv) ) - end do -end if - -DO JSV = NSV_CHEMBEG,NSV_CHEMEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_CHICBEG,NSV_CHICEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_AERBEG,NSV_AEREND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_LNOXBEG,NSV_LNOXEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_DSTBEG,NSV_DSTEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_SLTBEG,NSV_SLTEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_PPBEG,NSV_PPEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -#ifdef MNH_FOREFIRE -DO JSV = NSV_FFBEG,NSV_FFEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -#endif -DO JSV = NSV_CSBEG,NSV_CSEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_DSTDEPBEG,NSV_DSTDEPEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_SLTDEPBEG,NSV_SLTDEPEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_AERDEPBEG,NSV_AERDEPEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -DO JSV = NSV_SNWBEG,NSV_SNWEND - XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.) -END DO -IF (CELEC .NE. 'NONE') THEN - XRSVS(:,:,:,NSV_ELECBEG) = MAX(XRSVS(:,:,:,NSV_ELECBEG),0.) - XRSVS(:,:,:,NSV_ELECEND) = MAX(XRSVS(:,:,:,NSV_ELECEND),0.) -END IF - -if ( lbudget_sv ) then - do jsv = 1, nsv - call Budget_store_end( tbudgets(jsv + NBUDGET_SV1 - 1), 'NEGA2', xrsvs(:, :, :, jsv) ) - end do -end if -! -CALL SECOND_MNH2(ZTIME2) -! -XT_DIFF = XT_DIFF + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 14. UPPER AND LATERAL RELAXATION -! ---------------------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF(LVE_RELAX .OR. LVE_RELAX_GRD .OR. LHORELAX_UVWTH .OR. LHORELAX_RV .OR.& - LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. & - LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. & - ANY(LHORELAX_SV)) THEN - CALL RELAXATION (LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV,LHORELAX_RC, & - LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, & - LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, & - LHORELAX_SVC2R2,LHORELAX_SVC1R3, & - LHORELAX_SVELEC,LHORELAX_SVLG, & - LHORELAX_SVCHEM,LHORELAX_SVCHIC,LHORELAX_SVAER, & - LHORELAX_SVDST,LHORELAX_SVSLT,LHORELAX_SVPP, & - LHORELAX_SVCS,LHORELAX_SVSNW, & -#ifdef MNH_FOREFIRE - LHORELAX_SVFF, & -#endif - KTCOUNT,NRR,NSV,XTSTEP,XRHODJ, & - XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, & - XLSUM, XLSVM, XLSWM, XLSTHM, & - XLBXUM, XLBXVM, XLBXWM, XLBXTHM, & - XLBXRM, XLBXSVM, XLBXTKEM, & - XLBYUM, XLBYVM, XLBYWM, XLBYTHM, & - XLBYRM, XLBYSVM, XLBYTKEM, & - NALBOT, XALK, XALKW, & - NALBAS, XALKBAS, XALKWBAS, & - LMASK_RELAX,XKURELAX, XKVRELAX, XKWRELAX, & - NRIMX,NRIMY, & - XRUS, XRVS, XRWS, XRTHS, XRRS, XRSVS, XRTKES ) -END IF - -IF (CELEC.NE.'NONE' .AND. LRELAX2FW_ION) THEN - CALL RELAX2FW_ION (KTCOUNT, IMI, XTSTEP, XRHODJ, XSVT, NALBOT, & - XALK, LMASK_RELAX, XKWRELAX, XRSVS ) -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_RELAX = XT_RELAX + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 15. PARAMETRIZATIONS' MONITOR -! ------------------------- -! -ZTIME1 = ZTIME2 -! -CALL PHYS_PARAM_n( KTCOUNT, TZBAKFILE, & - XT_RAD, XT_SHADOWS, XT_DCONV, XT_GROUND, & - XT_MAFL, XT_DRAG, XT_EOL, XT_TURB, XT_TRACER, & - ZTIME, ZWETDEPAER, GMASKkids, GCLOUD_ONLY ) -! -IF (CDCONV/='NONE') THEN - XPACCONV = XPACCONV + XPRCONV * XTSTEP - IF (LCH_CONV_LINOX) THEN - XIC_TOTAL_NUMBER = XIC_TOTAL_NUMBER + XIC_RATE * XTSTEP - XCG_TOTAL_NUMBER = XCG_TOTAL_NUMBER + XCG_RATE * XTSTEP - END IF -END IF -! -! -CALL SECOND_MNH2(ZTIME2) -! -XT_PARAM = XT_PARAM + ZTIME2 - ZTIME1 - XTIME_LES - ZTIME -! -!------------------------------------------------------------------------------- -! -!* 16. TEMPORAL SERIES -! --------------- -! -ZTIME1 = ZTIME2 -! -IF (LSERIES) THEN - IF ( MOD (KTCOUNT-1,NFREQSERIES) == 0 ) CALL SERIES_n -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_STEP_MISC = XT_STEP_MISC + ZTIME2 - ZTIME1 -! -!------------------------------------------------------------------------------- -! -!* 17. LARGE SCALE FIELD REFRESH -! ------------------------- -! -ZTIME1 = ZTIME2 -! -IF (.NOT. LSTEADYLS) THEN - IF ( IMI==1 .AND. & - NCPL_CUR < NCPL_NBR ) THEN - IF (KTCOUNT+1 == NCPL_TIMES(NCPL_CUR,1) ) THEN - ! The next current time reachs a - NCPL_CUR=NCPL_CUR+1 ! coupling one, LS sources are refreshed - ! - CALL LS_COUPLING(XTSTEP,GSTEADY_DMASS,CCONF, & - CGETTKET, & - CGETRVT,CGETRCT,CGETRRT,CGETRIT, & - CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, NSV, & - NIMAX_ll,NJMAX_ll, & - NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, & - NSIZELBXTKE_ll,NSIZELBYTKE_ll, & - NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, & - XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, & - XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, & - XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, & - XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, & - XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, & - XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS ) - ! - DO JSV=NSV_CHEMBEG,NSV_CHEMEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_LNOXBEG,NSV_LNOXEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_AERBEG,NSV_AEREND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_DSTBEG,NSV_DSTEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_DSTDEPBEG,NSV_DSTDEPEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_SLTBEG,NSV_SLTEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_SLTDEPBEG,NSV_SLTDEPEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_PPBEG,NSV_PPEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! -#ifdef MNH_FOREFIRE - DO JSV=NSV_FFBEG,NSV_FFEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! -#endif - DO JSV=NSV_CSBEG,NSV_CSEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - DO JSV=NSV_SNWBEG,NSV_SNWEND - XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.) - XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.) - ENDDO - ! - END IF - END IF -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_COUPL = XT_COUPL + ZTIME2 - ZTIME1 -! -!------------------------------------------------------------------------------- -! -! -! -!* 8 Bis . Blowing snow scheme -! --------- -! -IF ( LBLOWSNOW ) THEN - CALL BLOWSNOW( XTSTEP, NRR, XPABST, XTHT, XRT, XZZ, XRHODREF, & - XRHODJ, XEXNREF, XRRS, XRTHS, XSVT, XRSVS, XSNWSUBL3D ) -ENDIF -! -!----------------------------------------------------------------------- -! -!* 8 Ter VISCOSITY (no-slip condition inside) -! --------- -! -! -IF ( LVISC ) THEN -! -ZTIME1 = ZTIME2 -! - CALL VISCOSITY(CLBCX, CLBCY, NRR, NSV, XMU_V,XPRANDTL, & - LVISC_UVW,LVISC_TH,LVISC_SV,LVISC_R, & - LDRAG, & - XUT, XVT, XWT, XTHT, XRT, XSVT, & - XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, & - XRUS, XRVS, XRWS, XRTHS, XRRS, XRSVS,XDRAG ) -! -ENDIF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_VISC = XT_VISC + ZTIME2 - ZTIME1 -!! -!------------------------------------------------------------------------------- -! -!* 9. ADVECTION -! --------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -!$acc update device(XRTHS) -! -!XRWS_PRES copy and not copyout (hidden in UPDATE_HALO) -!$acc data create (XUT, XVT, XWT) & -!$acc & copyin ( XRT, XSVT, XRTHS_CLD, XRRS_CLD ) & -!$acc & copy (XRRS, XRWS_PRES) & -!$acc & present(XDXX, XDYY, XDZZ, XDZX, XDZY, XRHODJ, XRUS, XRVS, XRWS ) & -!$acc & present(XTHT) -! -!$acc update device(XUT, XVT, XWT, XRHODJ) -!$acc update device(XRUS, XRVS, XRWS) -!$acc update device(XPABST,XTHT) -! -!$acc data copyin (XTKET, XRSVS_CLD) & -!$acc & copy (XRTKES, XRSVS) & -!$acc & copyout(XRTKEMS) -#ifdef MNH_BITREP_OMP -CALL SBR_FZ(XRRS_CLD) -CALL SBR_FZ(XRT) -#endif -CALL ADVECTION_METSV ( TZBAKFILE, CUVW_ADV_SCHEME, & - CMET_ADV_SCHEME, CSV_ADV_SCHEME, CCLOUD, NSPLIT, & - LSPLIT_CFL, XSPLIT_CFL, LCFL_WRIT, & - CLBCX, CLBCY, NRR, NSV, TDTCUR, XTSTEP, & - XUT, XVT, XWT, XTHT, XRT, XTKET, XSVT, XPABST, & - XTHVREF, XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, & - XRTHS, XRRS, XRTKES, XRSVS, & - XRTHS_CLD, XRRS_CLD, XRSVS_CLD, XRTKEMS ) -!$acc end data -! -!$acc update host(XRTHS) -! -CALL SECOND_MNH2(ZTIME2) -! -XT_ADV = XT_ADV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -!$acc kernels present( ZRWS ) -ZRWS(:,:,:) = XRWS(:,:,:) -!$acc end kernels -! -CALL GRAVITY_IMPL ( CLBCX, CLBCY, NRR, NRRL, NRRI,XTSTEP, & - XTHT, XRT, XTHVREF, XRHODJ, XRWS, XRTHS, XRRS, & - XRTHS_CLD, XRRS_CLD ) -! -! At the initial instant the difference with the ref state creates a -! vertical velocity production that must not be advected as it is -! compensated by the pressure gradient -! -IF (KTCOUNT == 1 .AND. CCONF=='START') THEN -!$acc kernels present( ZRWS,XRWS_PRES) - XRWS_PRES(:,:,:) = ZRWS(:,:,:) - XRWS(:,:,:) -!$acc end kernels -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_GRAV = XT_GRAV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -IF ( LIBM .AND. CIBM_ADV=='FORCIN' ) THEN - ! - ZTIME1=ZTIME2 - ! - CALL IBM_FORCING_ADV (XRUS,XRVS,XRWS) - ! - CALL SECOND_MNH2(ZTIME2) - ! - XT_IBM_FORC = XT_IBM_FORC + ZTIME2 - ZTIME1 - ! -ENDIF -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF ((CUVW_ADV_SCHEME(1:3)=='CEN') .AND. (CTEMP_SCHEME == 'LEFR')) THEN - IF (CUVW_ADV_SCHEME=='CEN4TH') THEN - NULLIFY(TZFIELDC_ll) - NULLIFY(TZHALO2C_ll) - CALL ADD3DFIELD_ll( TZFIELDC_ll, XUT, 'MODEL_n::XUT' ) - CALL ADD3DFIELD_ll( TZFIELDC_ll, XVT, 'MODEL_n::XVT' ) - CALL ADD3DFIELD_ll( TZFIELDC_ll, XWT, 'MODEL_n::XWT' ) -#ifndef MNH_OPENACC - CALL INIT_HALO2_ll(TZHALO2C_ll,3,IIU,IJU,IKU) - CALL UPDATE_HALO_ll(TZFIELDC_ll,IINFO_ll) - CALL UPDATE_HALO2_ll(TZFIELDC_ll, TZHALO2C_ll, IINFO_ll) -#else - IF (GFIRST_CALL_MODELN) THEN - GFIRST_CALL_MODELN = .FALSE. - NULLIFY(TZHALO2_UT,TZHALO2_VT,TZHALO2_WT) - CALL INIT_HALO2_ll(TZHALO2_UT,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_VT,1,IIU,IJU,IKU) - CALL INIT_HALO2_ll(TZHALO2_WT,1,IIU,IJU,IKU) - END IF - - CALL GET_HALO2_DF(XUT,TZHALO2_UT,HNAME='XUT') - CALL GET_HALO2_DF(XVT,TZHALO2_VT,HNAME='XVT') - CALL GET_HALO2_DF(XWT,TZHALO2_WT,HNAME='XWT') -#endif -!$acc update device(XUT, XVT, XWT) - END IF -!$acc data copyin(XUM, XVM, XWM) & -!$acc & copy (XDUM, XDVM, XDWM) - CALL ADVECTION_UVW_CEN(CUVW_ADV_SCHEME, & - CLBCX, CLBCY, & - XTSTEP, KTCOUNT, & - XUM, XVM, XWM, XDUM, XDVM, XDWM, & - XUT, XVT, XWT, & - XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, & - XRUS,XRVS, XRWS, & -#ifndef MNH_OPENACC - TZHALO2C_ll ) -#else - TZHALO2_UT,TZHALO2_VT,TZHALO2_WT ) -#endif -!$acc end data - IF (CUVW_ADV_SCHEME=='CEN4TH') THEN - CALL CLEANLIST_ll(TZFIELDC_ll) - NULLIFY(TZFIELDC_ll) -#ifndef MNH_OPENACC - CALL DEL_HALO2_ll(TZHALO2C_ll) - NULLIFY(TZHALO2C_ll) -#endif - END IF -ELSE - -!$acc data copyin(XRUS_PRES, XRVS_PRES) - CALL ADVECTION_UVW(CUVW_ADV_SCHEME, CTEMP_SCHEME, & - NWENO_ORDER, LSPLIT_WENO, & - CLBCX, CLBCY, XTSTEP, & - XUT, XVT, XWT, & - XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, & - XRUS, XRVS, XRWS, & - XRUS_PRES, XRVS_PRES, XRWS_PRES ) -!$acc end data -END IF -! -!$acc end data -! -CALL SECOND_MNH2(ZTIME2) -! -XT_ADVUVW = XT_ADVUVW + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -IF (NMODEL_CLOUD==IMI .AND. CTURBLEN_CLOUD/='NONE') THEN - CALL TURB_CLOUD_INDEX( XTSTEP, TZBAKFILE, & - LTURB_DIAG, NRRI, & - XRRS, XRT, XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, & - XCEI ) -END IF -! -!------------------------------------------------------------------------------- -! -!* 18. LATERAL BOUNDARY CONDITION FOR THE NORMAL VELOCITY -! -------------------------------------------------- -! -ZTIME1 = ZTIME2 -! -!$acc update self( XRUS, XRVS, XRWS ) -!$acc kernels present(ZRUS,ZRVS,ZRWS) -ZRUS(:,:,:)=XRUS(:,:,:) -ZRVS(:,:,:)=XRVS(:,:,:) -ZRWS(:,:,:)=XRWS(:,:,:) -!$acc end kernels -! -if ( .not. l1d ) then - if ( lbudget_u ) call Budget_store_init( tbudgets(NBUDGET_U), 'PRES', xrus(:, :, :) ) - if ( lbudget_v ) call Budget_store_init( tbudgets(NBUDGET_V), 'PRES', xrvs(:, :, :) ) - if ( lbudget_w ) call Budget_store_init( tbudgets(NBUDGET_W), 'PRES', xrws(:, :, :) ) -end if -! -CALL MPPDB_CHECK3DM("before RAD_BOUND : other var",PRECISION,XUT,XVT,XRHODJ,XTKET) -CALL MPPDB_CHECKLB(XLBXUM,"modeln XLBXUM",PRECISION,'LBXU',NRIMX) -CALL MPPDB_CHECKLB(XLBYVM,"modeln XLBYVM",PRECISION,'LBYV',NRIMY) -CALL MPPDB_CHECKLB(XLBXUS,"modeln XLBXUS",PRECISION,'LBXU',NRIMX) -CALL MPPDB_CHECKLB(XLBYVS,"modeln XLBYVS",PRECISION,'LBYV',NRIMY) -! -CALL RAD_BOUND (CLBCX,CLBCY,CTURB,XCARPKMAX, & - XTSTEP, & - XDXHAT, XDYHAT, XZHAT, & - XUT, XVT, & - XLBXUM, XLBYVM, XLBXUS, XLBYVS, & - XFLUCTUNW,XFLUCTVNN,XFLUCTUNE,XFLUCTVNS, & - XCPHASE, XCPHASE_PBL, XRHODJ, & - XTKET,XRUS, XRVS, XRWS ) -!$acc update device( XRUS, XRVS, XRWS ) -!$acc kernels present(ZRUS,ZRVS,ZRWS) -ZRUS(:,:,:)=XRUS(:,:,:)-ZRUS(:,:,:) -ZRVS(:,:,:)=XRVS(:,:,:)-ZRVS(:,:,:) -ZRWS(:,:,:)=XRWS(:,:,:)-ZRWS(:,:,:) -!$acc end kernels -! -CALL SECOND_MNH2(ZTIME2) -! -XT_RAD_BOUND = XT_RAD_BOUND + ZTIME2 - ZTIME1 -! -!------------------------------------------------------------------------------- -! -!* 19. PRESSURE COMPUTATION -! -------------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -!$acc kernels present(ZPABST) -ZPABST(:,:,:) = XPABST(:,:,:) -!$acc end kernels -! -IF(.NOT. L1D) THEN -! - !$acc kernels present(XRUS,XRVS,XRWS) !present(XRUS_PRES,XRVS_PRES,XRWS_PRES) - XRUS_PRES(:,:,:) = XRUS(:,:,:) - XRVS_PRES(:,:,:) = XRVS(:,:,:) - XRWS_PRES(:,:,:) = XRWS(:,:,:) - !$acc end kernels - ! - CALL PRESSUREZ( CLBCX,CLBCY,CPRESOPT,NITR,LITRADJ,KTCOUNT, XRELAX,IMI, & - XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY,XDXHATM,XDYHATM,XRHOM, & - XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY, & - NRR,NRRL,NRRI,XDRYMASST,XREFMASS,XMASS_O_PHI0, & - XTHT,XRT,XRHODREF,XTHVREF,XRVREF,XEXNREF, XLINMASS, & - XRUS, XRVS, XRWS, XPABST, & - XBFB, & - XBF_SXP2_YP1_Z, & - XAF_ZS,XBF_ZS,XCF_ZS, & - XDXATH_ZS,XDYATH_ZS,XRHO_ZS, & - XA_K,XB_K,XC_K,XD_K) !JUAN FULL ZSOLVER - ! - !$acc update host(XPABST) - !$acc kernels present(XRUS,XRVS,XRWS) !present(XRUS_PRES,XRVS_PRES,XRWS_PRES) - XRUS_PRES(:,:,:) = XRUS(:,:,:) - XRUS_PRES(:,:,:) + ZRUS(:,:,:) - XRVS_PRES(:,:,:) = XRVS(:,:,:) - XRVS_PRES(:,:,:) + ZRVS(:,:,:) - XRWS_PRES(:,:,:) = XRWS(:,:,:) - XRWS_PRES(:,:,:) + ZRWS(:,:,:) - !$acc end kernels - !$acc update host(XRUS,XRVS,XRWS) - CALL MPPDB_CHECK3DM("after pressurez:XRU/V/WS",PRECISION,XRUS,XRVS,XRWS) - CALL MPPDB_CHECK3DM("after pressurez:ZRU/V/WS",PRECISION,ZRUS,ZRVS,ZRWS) - CALL MPPDB_CHECK3DM("after pressurez:XRU/V/WS_PRES",PRECISION,& - XRUS_PRES,XRVS_PRES,XRWS_PRES ) -! -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_PRESS = XT_PRESS + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 20. CHEMISTRY/AEROSOLS -! ------------------ -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF (LUSECHEM) THEN - CALL CH_MONITOR_n(ZWETDEPAER,KTCOUNT,XTSTEP, ILUOUT, NVERB) -END IF -! -! For inert aerosol (dust and sea salt) => aer_monitor_n -IF ((LDUST).OR.(LSALT)) THEN -! -! tests to see if any cloud exists -! - GCLD=.TRUE. - IF (GCLD .AND. NRR.LE.3 ) THEN - IF( MAXVAL(XCLDFR(:,:,:)).LE. 1.E-10 .AND. GCLOUD_ONLY ) THEN - GCLD = .FALSE. ! only the cloudy verticals would be - ! refreshed but there is no clouds - END IF - END IF -! - IF (GCLD .AND. NRR.GE.4 ) THEN - IF( CCLOUD(1:3)=='ICE' )THEN - IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN(2) .AND. & - MAXVAL(XRT(:,:,:,4)).LE.XRTMIN(4) .AND. GCLOUD_ONLY ) THEN - GCLD = .FALSE. ! only the cloudy verticals would be - ! refreshed but there is no cloudwater and ice - END IF - END IF - IF( CCLOUD=='C3R5' )THEN - IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN_C1R3(2) .AND. & - MAXVAL(XRT(:,:,:,4)).LE.XRTMIN_C1R3(4) .AND. GCLOUD_ONLY ) THEN - GCLD = .FALSE. ! only the cloudy verticals would be - ! refreshed but there is no cloudwater and ice - END IF - END IF - IF( CCLOUD=='LIMA' )THEN - IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN_LIMA(2) .AND. & - MAXVAL(XRT(:,:,:,4)).LE.XRTMIN_LIMA(4) .AND. GCLOUD_ONLY ) THEN - GCLD = .FALSE. ! only the cloudy verticals would be - ! refreshed but there is no cloudwater and ice - END IF - END IF - END IF - -! - CALL AER_MONITOR_n(KTCOUNT,XTSTEP, ILUOUT, NVERB, GCLD) -END IF -! -! -CALL SECOND_MNH2(ZTIME2) -! -XT_CHEM = XT_CHEM + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -ZTIME = ZTIME + XTIME_LES_BU_PROCESS + XTIME_BU_PROCESS - -!------------------------------------------------------------------------------- -! -!* 20. WATER MICROPHYSICS -! ------------------ -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF (CCLOUD /= 'NONE' .AND. CELEC == 'NONE') THEN -! - IF (CCLOUD == 'C2R2' .OR. CCLOUD == 'KHKO' .OR. CCLOUD == 'C3R5' & - .OR. CCLOUD == "LIMA" ) THEN - IF ( LFORCING ) THEN - XWT_ACT_NUC(:,:,:) = XWT(:,:,:) + XWTFRC(:,:,:) - ELSE - XWT_ACT_NUC(:,:,:) = XWT(:,:,:) - END IF - IF (CTURB /= 'NONE' ) THEN - IF ( ((CCLOUD=='C2R2'.OR.CCLOUD=='KHKO').AND.LACTTKE) .OR. (CCLOUD=='LIMA'.AND.MACTTKE) ) THEN - XWT_ACT_NUC(:,:,:) = XWT_ACT_NUC(:,:,:) + (2./3. * XTKET(:,:,:))**0.5 - ELSE - XWT_ACT_NUC(:,:,:) = XWT_ACT_NUC(:,:,:) - ENDIF - ENDIF - ELSE - XWT_ACT_NUC(:,:,:) = 0. - END IF -! - XRTHS_CLD(:, :, : ) = XRTHS(:, :, : ) - XRRS_CLD (:, :, :, : ) = XRRS(:, :, :, : ) - XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : ) -!$acc data present( XRHODJ, XRTHS, ZPABST ) & -!$acc & copyin (XZZ, XTHT, XSIGS, VSIGQSAT, XMFCONV, XTHM, XPABSM, & -!$acc & XRCM, XWT_ACT_NUC, XDTHRAD, XCF_MF, XRC_MF, XRI_MF, & -!$acc & XSOLORG, XMI) & -!$acc & copy (XSUPSAT, XNACT, XNPRO, XSSPRO, & -!$acc & XRT, XRRS, XSVT, XRSVS, XCLDFR, XCIT, XINPRR3D, XEVAP3D, & -!$acc & XINPRC, XINPRR, XINPRS, XINPRG, XINPRH, XINDEP, & -!$acc & XHLC_HRC, XHLC_HCF, XHLI_HRI, XHLI_HCF) & -!$acc & copyout(XSRCT, XRAINFR) - -!$acc update device (XRTHS) - - IF (CSURF=='EXTE') THEN -#ifndef MNH_OPENACC - ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2))) - ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2))) -#else - CALL MNH_MEM_GET( ZSEA, SIZE( XRHODJ, 1 ), SIZE( XRHODJ, 2 ) ) - - CALL MNH_MEM_POSITION_PIN() - CALL MNH_MEM_GET( ZTOWN, SIZE( XRHODJ, 1 ), SIZE( XRHODJ, 2 ) ) -#endif - CALL MNHGET_SURF_PARAM_n (PSEA=ZSEA(:,:),PTOWN=ZTOWN(:,:)) -!$acc update device( ZSEA, ZTOWN ) - CALL RESOLVED_CLOUD ( CCLOUD, CACTCCN, CSCONV, CMF_CLOUD, NRR, NSPLITR, & - NSPLITG, IMI, KTCOUNT, & - CLBCX,CLBCY,TZBAKFILE, CRAD, CTURBDIM, & - LSUBG_COND,LSIGMAS,CSUBG_AUCV,XTSTEP, & - XZZ, XRHODJ, XRHODREF, XEXNREF, & - ZPABST, XTHT,XRT,XSIGS,VSIGQSAT,XMFCONV,XTHM,XRCM, & - XPABSM, XWT_ACT_NUC,XDTHRAD, XRTHS, XRRS, & - XSVT, XRSVS, & - XSRCT, XCLDFR,XCIT, & - LSEDIC,KACTIT, KSEDC, KSEDI, KRAIN, KWARM, KHHONI, & - LCONVHG, XCF_MF,XRC_MF, XRI_MF, & -! XINPRC,ZINPRC3D,XINPRR, XINPRR3D, XEVAP3D, & -! XINPRS,ZINPRS3D, XINPRG,ZINPRG3D, XINPRH,ZINPRH3D, & -! XSOLORG, XMI,ZSPEEDC, ZSPEEDR, ZSPEEDS, ZSPEEDG, ZSPEEDH, & - XINPRC,XINPRR, XINPRR3D, XEVAP3D, & - XINPRS, XINPRG, XINPRH, & - XSOLORG, XMI, & - XINDEP, XSUPSAT, XNACT, XNPRO,XSSPRO, XRAINFR, & - XHLC_HRC, XHLC_HCF, XHLI_HRI, XHLI_HCF, & - ZSEA, ZTOWN ) -#ifndef MNH_OPENACC - DEALLOCATE(ZTOWN) -#else - CALL MNH_MEM_RELEASE() !Release ZTOWN -#endif - ELSE - CALL RESOLVED_CLOUD ( CCLOUD, CACTCCN, CSCONV, CMF_CLOUD, NRR, NSPLITR, & - NSPLITG, IMI, KTCOUNT, & - CLBCX,CLBCY,TZBAKFILE, CRAD, CTURBDIM, & - LSUBG_COND,LSIGMAS,CSUBG_AUCV, & - XTSTEP,XZZ, XRHODJ, XRHODREF, XEXNREF, & - ZPABST, XTHT,XRT,XSIGS,VSIGQSAT,XMFCONV,XTHM,XRCM, & - XPABSM, XWT_ACT_NUC,XDTHRAD, XRTHS, XRRS, & - XSVT, XRSVS, & - XSRCT, XCLDFR,XCIT, & - LSEDIC,KACTIT, KSEDC, KSEDI, KRAIN, KWARM, KHHONI, & - LCONVHG, XCF_MF,XRC_MF, XRI_MF, & -! XINPRC,ZINPRC3D,XINPRR, XINPRR3D, XEVAP3D, & -! XINPRS,ZINPRS3D, XINPRG,ZINPRG3D, XINPRH,ZINPRH3D, & -! XSOLORG, XMI,ZSPEEDC, ZSPEEDR, ZSPEEDS, ZSPEEDG, ZSPEEDH, & - XINPRC,XINPRR, XINPRR3D, XEVAP3D, & - XINPRS, XINPRG, XINPRH, & - XSOLORG, XMI, & - XINDEP, XSUPSAT, XNACT, XNPRO,XSSPRO, XRAINFR, & - XHLC_HRC, XHLC_HCF, XHLI_HRI, XHLI_HCF ) - END IF -!$acc end data - -!$acc update host(XRTHS) - - XRTHS_CLD(:, :, : ) = XRTHS(:, :, : ) - XRTHS_CLD(:, :, : ) - XRRS_CLD (:, :, :, : ) = XRRS (:, :, :, : ) - XRRS_CLD (:, :, :, : ) - XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : ) - XRSVS_CLD(:, :, :, : ) -! - IF (CCLOUD /= 'REVE' ) THEN - XACPRR = XACPRR + XINPRR * XTSTEP - IF ( (CCLOUD(1:3) == 'ICE' .AND. LSEDIC ) .OR. & - ((CCLOUD == 'C2R2' .OR. CCLOUD == 'C3R5' .OR. CCLOUD == 'KHKO' & - .OR. CCLOUD == 'LIMA' ) .AND. KSEDC ) ) THEN - XACPRC = XACPRC + XINPRC * XTSTEP - IF (LDEPOSC .OR. LDEPOC) XACDEP = XACDEP + XINDEP * XTSTEP - END IF - IF (CCLOUD(1:3) == 'ICE' .OR. CCLOUD == 'C3R5' .OR. & - (CCLOUD == 'LIMA' .AND. LCOLD ) ) THEN - XACPRS = XACPRS + XINPRS * XTSTEP - XACPRG = XACPRG + XINPRG * XTSTEP - IF (CCLOUD == 'ICE4' .OR. (CCLOUD == 'LIMA' .AND. LHAIL)) XACPRH = XACPRH + XINPRH * XTSTEP - END IF -! -! Lessivage des CCN et IFN nucléables par Slinn -! - IF (LSCAV .AND. (CCLOUD == 'LIMA')) THEN - CALL LIMA_PRECIP_SCAVENGING(CCLOUD, ILUOUT, KTCOUNT,XTSTEP,XRT(:,:,:,3), & - XRHODREF, XRHODJ, XZZ, XPABST, XTHT, & - XSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), & - XRSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), XINPAP ) -! - XACPAP(:,:) = XACPAP(:,:) + XINPAP(:,:) * XTSTEP - END IF - END IF -! -! It is necessary that SV_C2R2 and SV_C1R3 are contiguous in the preceeding CALL -! -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_CLOUD = XT_CLOUD + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 21. CLOUD ELECTRIFICATION AND LIGHTNING FLASHES -! ------------------------------------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -XTIME_LES_BU_PROCESS = 0. -! -IF (CELEC /= 'NONE' .AND. (CCLOUD(1:3) == 'ICE')) THEN - XWT_ACT_NUC(:,:,:) = 0. -! - XRTHS_CLD = XRTHS - XRRS_CLD = XRRS - XRSVS_CLD = XRSVS - IF (CSURF=='EXTE') THEN -#ifndef MNH_OPENACC - ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2))) - ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2))) -#else - CALL MNH_MEM_GET( ZSEA, SIZE( XRHODJ, 1 ), SIZE( XRHODJ, 2 ) ) - - CALL MNH_MEM_POSITION_PIN() - CALL MNH_MEM_GET( ZTOWN, SIZE( XRHODJ, 1 ), SIZE( XRHODJ, 2 ) ) -#endif - CALL MNHGET_SURF_PARAM_n (PSEA=ZSEA(:,:),PTOWN=ZTOWN(:,:)) - CALL RESOLVED_ELEC_n (CCLOUD, CSCONV, CMF_CLOUD, & - NRR, NSPLITR, IMI, KTCOUNT, OEXIT, & - CLBCX, CLBCY, CRAD, CTURBDIM, & - LSUBG_COND, LSIGMAS,VSIGQSAT,CSUBG_AUCV, & - XTSTEP, XZZ, XRHODJ, XRHODREF, XEXNREF, & - ZPABST, XTHT, XRTHS, XWT, XRT, XRRS, & - XSVT, XRSVS, XCIT, & - XSIGS, XSRCT, XCLDFR, XMFCONV, XCF_MF, XRC_MF, & - XRI_MF, LSEDIC, LWARM, & - XINPRC, XINPRR, XINPRR3D, XEVAP3D, & - XINPRS, XINPRG, XINPRH, & - ZSEA, ZTOWN ) -#ifndef MNH_OPENACC - DEALLOCATE(ZTOWN) -#else - CALL MNH_MEM_RELEASE() !Release ZTOWN -#endif - ELSE - CALL RESOLVED_ELEC_n (CCLOUD, CSCONV, CMF_CLOUD, & - NRR, NSPLITR, IMI, KTCOUNT, OEXIT, & - CLBCX, CLBCY, CRAD, CTURBDIM, & - LSUBG_COND, LSIGMAS,VSIGQSAT, CSUBG_AUCV, & - XTSTEP, XZZ, XRHODJ, XRHODREF, XEXNREF, & - ZPABST, XTHT, XRTHS, XWT, & - XRT, XRRS, XSVT, XRSVS, XCIT, & - XSIGS, XSRCT, XCLDFR, XMFCONV, XCF_MF, XRC_MF, & - XRI_MF, LSEDIC, LWARM, & - XINPRC, XINPRR, XINPRR3D, XEVAP3D, & - XINPRS, XINPRG, XINPRH ) - END IF - XRTHS_CLD = XRTHS - XRTHS_CLD - XRRS_CLD = XRRS - XRRS_CLD - XRSVS_CLD = XRSVS - XRSVS_CLD -! - XACPRR = XACPRR + XINPRR * XTSTEP - IF ((CCLOUD(1:3) == 'ICE' .AND. LSEDIC)) & - XACPRC = XACPRC + XINPRC * XTSTEP - IF (CCLOUD(1:3) == 'ICE') THEN - XACPRS = XACPRS + XINPRS * XTSTEP - XACPRG = XACPRG + XINPRG * XTSTEP - IF (CCLOUD == 'ICE4') XACPRH = XACPRH + XINPRH * XTSTEP - END IF -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_ELEC = XT_ELEC + ZTIME2 - ZTIME1 & - - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 21. L.E.S. COMPUTATIONS -! ------------------- -! -ZTIME1 = ZTIME2 -! -CALL LES_n -! -CALL SECOND_MNH2(ZTIME2) -! -XT_SPECTRA = XT_SPECTRA + ZTIME2 - ZTIME1 + XTIME_LES_BU + XTIME_LES -! -!------------------------------------------------------------------------------- -! -!* 21. bis MEAN_UM -! -------------------- -! -IF (LMEAN_FIELD) THEN - CALL MEAN_FIELD(XUT, XVT, XWT, XTHT, XTKET, XPABST, XSVT(:,:,:,1)) -END IF -! -!------------------------------------------------------------------------------- -! -!* 22. UPDATE HALO OF EACH SUBDOMAINS FOR TIME T+DT -! -------------------------------------------- -! -ZTIME1 = ZTIME2 -! -CALL EXCHANGE (XTSTEP,NRR,NSV,XRHODJ,TFIELDS_ll, & - XRUS, XRVS,XRWS,XRTHS,XRRS,XRTKES,XRSVS) -! -CALL SECOND_MNH2(ZTIME2) -! -XT_HALO = XT_HALO + ZTIME2 - ZTIME1 -! -!------------------------------------------------------------------------------- -! -!* 23. TEMPORAL SWAPPING -! ----------------- -! -ZTIME1 = ZTIME2 -XTIME_BU_PROCESS = 0. -! -CALL ENDSTEP ( XTSTEP,NRR,NSV,KTCOUNT,IMI, & - CUVW_ADV_SCHEME,CTEMP_SCHEME,XRHODJ, & - XRUS,XRVS,XRWS,XDRYMASSS, & - XRTHS,XRRS,XRTKES,XRSVS, & - XLSUS,XLSVS,XLSWS, & - XLSTHS,XLSRVS,XLSZWSS, & - XLBXUS,XLBXVS,XLBXWS, & - XLBXTHS,XLBXRS,XLBXTKES,XLBXSVS, & - XLBYUS,XLBYVS,XLBYWS, & - XLBYTHS,XLBYRS,XLBYTKES,XLBYSVS, & - XUM,XVM,XWM,XZWS, & - XUT,XVT,XWT,XPABST,XDRYMASST, & - XTHT, XRT, XTHM, XRCM, XPABSM,XTKET, XSVT,& - XLSUM,XLSVM,XLSWM, & - XLSTHM,XLSRVM,XLSZWSM, & - XLBXUM,XLBXVM,XLBXWM, & - XLBXTHM,XLBXRM,XLBXTKEM,XLBXSVM, & - XLBYUM,XLBYVM,XLBYWM, & - XLBYTHM,XLBYRM,XLBYTKEM,XLBYSVM ) -! -CALL SECOND_MNH2(ZTIME2) -! -XT_STEP_SWA = XT_STEP_SWA + ZTIME2 - ZTIME1 - XTIME_BU_PROCESS -! -!------------------------------------------------------------------------------- -! -!* 24.1 BALLOON and AIRCRAFT -! -------------------- -! -ZTIME1 = ZTIME2 -! -IF (LFLYER) & - CALL AIRCRAFT_BALLOON(XTSTEP, & - XXHAT, XYHAT, XZZ, XMAP, XLONORI, XLATORI, & - XUT, XVT, XWT, XPABST, XTHT, XRT, XSVT, XTKET, XTSRAD, & - XRHODREF,XCIT,PSEA=ZSEA(:,:)) - - -!------------------------------------------------------------------------------- -! -!* 24.2 STATION (observation diagnostic) -! -------------------------------- -! -IF (LSTATION) & - CALL STATION_n(XTSTEP, & - XXHAT, XYHAT, XZZ, & - XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, XTSRAD, XPABST ) -! -!--------------------------------------------------------- -! -!* 24.3 PROFILER (observation diagnostic) -! --------------------------------- -! -IF (LPROFILER) & - CALL PROFILER_n(XTSTEP, & - XXHAT, XYHAT, XZZ,XRHODREF, & - XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, XTSRAD, XPABST, & - XAER, XCLDFR, XCIT,PSEA=ZSEA(:,:)) -! -! -CALL SECOND_MNH2(ZTIME2) -! -XT_STEP_MISC = XT_STEP_MISC + ZTIME2 - ZTIME1 -! -!------------------------------------------------------------------------------- -! -!* 24.4 deallocation of observation diagnostics -! --------------------------------------- -! -CALL END_DIAG_IN_RUN -! -!------------------------------------------------------------------------------- -! -! -!* 25. STORAGE OF BUDGET FIELDS -! ------------------------ -! -ZTIME1 = ZTIME2 -! -IF ( .NOT. LIO_NO_WRITE ) THEN - IF (NBUMOD==IMI .AND. CBUTYPE/='NONE') THEN - CALL ENDSTEP_BUDGET(TDIAFILE,KTCOUNT,TDTCUR,XTSTEP,NSV) - END IF -END IF -! -CALL SECOND_MNH2(ZTIME2) -! -XT_STEP_BUD = XT_STEP_BUD + ZTIME2 - ZTIME1 + XTIME_BU -! -!------------------------------------------------------------------------------- -! -!* 26. FM FILE CLOSURE -! --------------- -! -IF ( tzbakfile%lopened ) THEN - CALL IO_File_close(TZBAKFILE) -END IF -! -!------------------------------------------------------------------------------- -! -!* 27. CURRENT TIME REFRESH -! -------------------- -! -TDTCUR%xtime=TDTCUR%xtime + XTSTEP -CALL DATETIME_CORRECTDATE(TDTCUR) -! -!------------------------------------------------------------------------------- -! -!* 28. CPU ANALYSIS -! ------------ -! -CALL SECOND_MNH2(ZTIME2) -XT_START=XT_START+ZTIME2-ZEND -! -! -IF ( KTCOUNT == NSTOP .AND. IMI==1) THEN - OEXIT=.TRUE. -END IF -! -IF (OEXIT) THEN -! - IF ( .NOT. LIO_NO_WRITE ) THEN - IF (LSERIES) CALL WRITE_SERIES_n(TDIAFILE) - CALL WRITE_AIRCRAFT_BALLOON(TDIAFILE) - CALL WRITE_STATION_n(TDIAFILE) - CALL WRITE_PROFILER_n(TDIAFILE) - call Write_les_n( tdiafile ) -#ifdef MNH_IOLFI - CALL MENU_DIACHRO(TDIAFILE,'END') -#endif - CALL IO_File_close(TDIAFILE) - END IF - ! - CALL IO_File_close(TINIFILE) - IF (CSURF=="EXTE") CALL IO_File_close(TINIFILEPGD) -! -!* 28.1 print statistics! -! - ! Set File Timing OUTPUT - ! - CALL SET_ILUOUT_TIMING(TLUOUT) - ! - ! Compute global time - ! - CALL TIME_STAT_ll(XT_START,ZTOT) - ! - CALL TIME_HEADER_ll(IMI) - ! - CALL TIME_STAT_ll(XT_1WAY,ZTOT, ' ONE WAY','=') - CALL TIME_STAT_ll(XT_BOUND,ZTOT, ' BOUNDARIES','=') - CALL TIME_STAT_ll(XT_STORE,ZTOT, ' STORE-FIELDS','=') - CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_SEND,ZTOT, ' W3D_SEND ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_RECV,ZTOT, ' W3D_RECV ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_WRIT,ZTOT, ' W3D_WRIT ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_WAIT,ZTOT, ' W3D_WAIT ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_ALL ,ZTOT, ' W3D_ALL ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_GATH,ZTOT, ' W2D_GATH ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_WRIT,ZTOT, ' W2D_WRIT ','-') - CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_ALL ,ZTOT, ' W2D_ALL ','-') - CALL TIME_STAT_ll(XT_GUESS,ZTOT, ' INITIAL_GUESS','=') - CALL TIME_STAT_ll(XT_2WAY,ZTOT, ' TWO WAY','=') - CALL TIME_STAT_ll(XT_ADV,ZTOT, ' ADVECTION MET','=') - CALL TIME_STAT_ll(XT_ADVUVW,ZTOT, ' ADVECTION UVW','=') - CALL TIME_STAT_ll(XT_GRAV,ZTOT, ' GRAVITY','=') - CALL TIME_STAT_ll(XT_FORCING,ZTOT, ' FORCING','=') - CALL TIME_STAT_ll(XT_IBM_FORC,ZTOT, ' IBM','=') - CALL TIME_STAT_ll(XT_NUDGING,ZTOT, ' NUDGING','=') - CALL TIME_STAT_ll(XT_SOURCES,ZTOT, ' DYN_SOURCES','=') - CALL TIME_STAT_ll(XT_DIFF,ZTOT, ' NUM_DIFF','=') - CALL TIME_STAT_ll(XT_RELAX,ZTOT, ' RELAXATION','=') - ! - CALL TIMING_LEGEND() - ! - CALL TIME_STAT_ll(XT_PARAM,ZTOT, ' PHYS_PARAM','=') - CALL TIME_STAT_ll(XT_RAD,ZTOT, ' RAD = '//CRAD ,'-') - CALL TIME_STAT_ll(XT_SHADOWS,ZTOT, ' SHADOWS' ,'-') - CALL TIME_STAT_ll(XT_DCONV,ZTOT, ' DEEP CONV = '//CDCONV,'-') - CALL TIME_STAT_ll(XT_GROUND,ZTOT, ' GROUND' ,'-') - CALL TIME_STAT_ll(XT_TURB,ZTOT, ' TURB = '//CTURB ,'-') - CALL TIME_STAT_ll(XT_MAFL,ZTOT, ' MAFL = '//CSCONV,'-') - CALL TIME_STAT_ll(XT_CHEM,ZTOT, ' CHIMIE' ,'-') - CALL TIME_STAT_ll(XT_EOL,ZTOT, ' WIND TURBINE' ,'-') - CALL TIMING_LEGEND() - CALL TIME_STAT_ll(XT_COUPL,ZTOT, ' SET_COUPLING','=') - CALL TIME_STAT_ll(XT_RAD_BOUND,ZTOT, ' RAD_BOUND','=') - ! - CALL TIMING_LEGEND() - ! - CALL TIME_STAT_ll(XT_PRESS,ZTOT, ' PRESSURE ','=','F') - !JUAN Z_SPLITTING - CALL TIME_STAT_ll(TIMEZ%T_MAP_B_SX_YP2_ZP1,ZTOT, ' REMAP B=>FFTXZ' ,'-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_SX_YP2_ZP1_SXP2_Y_ZP1,ZTOT, ' REMAP FFTXZ=>FFTYZ' ,'-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_B,ZTOT, ' REMAP FTTYZ=>B' ,'-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_SXP2_YP1_Z,ZTOT, ' REMAP FFTYZ=>SUBZ' ,'-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_B_SXP2_Y_ZP1,ZTOT, ' REMAP B=>FFTYZ-1','-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_YP1_Z_SXP2_Y_ZP1,ZTOT, ' REMAP SUBZ=>FFTYZ-1','-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_SX_YP2_ZP1,ZTOT, ' REMAP FFTYZ-1=>FFTXZ-1','-','F') - CALL TIME_STAT_ll(TIMEZ%T_MAP_SX_YP2_ZP1_B,ZTOT, ' REMAP FFTXZ-1=>B ' ,'-','F') - ! JUAN P1/P2 - CALL TIME_STAT_ll(XT_CLOUD,ZTOT, ' RESOLVED_CLOUD','=') - CALL TIME_STAT_ll(XT_ELEC,ZTOT, ' RESOLVED_ELEC','=') - CALL TIME_STAT_ll(XT_HALO,ZTOT, ' EXCHANGE_HALO','=') - CALL TIME_STAT_ll(XT_STEP_SWA,ZTOT, ' ENDSTEP','=') - CALL TIME_STAT_ll(XT_STEP_BUD,ZTOT, ' BUDGETS','=') - CALL TIME_STAT_ll(XT_SPECTRA,ZTOT, ' LES','=') - CALL TIME_STAT_ll(XT_STEP_MISC,ZTOT, ' MISCELLANEOUS','=') - IF (LIBM) CALL TIME_STAT_ll(XT_IBM_FORC,ZTOT,' IBM FORCING','=') - ! - ! sum of call subroutine - ! - ZALL = XT_1WAY + XT_BOUND + XT_STORE + XT_GUESS + XT_2WAY + & - XT_ADV + XT_FORCING + XT_NUDGING + XT_SOURCES + XT_DIFF + & - XT_ADVUVW + XT_GRAV + XT_IBM_FORC + & - XT_RELAX+ XT_PARAM + XT_COUPL + XT_RAD_BOUND+XT_PRESS + & - XT_CLOUD+ XT_ELEC + XT_HALO + XT_SPECTRA + XT_STEP_SWA + & - XT_STEP_MISC+ XT_STEP_BUD - CALL TIME_STAT_ll(ZALL,ZTOT, ' SUM(CALL)','=') - CALL TIMING_SEPARATOR('=') - ! - ! Gobale Stat - ! - WRITE(ILUOUT,FMT=*) - WRITE(ILUOUT,FMT=*) - CALL TIMING_LEGEND() - ! - ! MODELN all included - ! - CALL TIMING_SEPARATOR('+') - CALL TIMING_SEPARATOR('+') - WRITE(YMI,FMT="(I0)") IMI - CALL TIME_STAT_ll(XT_START,ZTOT, ' MODEL'//YMI,'+') - CALL TIMING_SEPARATOR('+') - CALL TIMING_SEPARATOR('+') - CALL TIMING_SEPARATOR('+') - ! - ! Timing/ Steps - ! - ZTIME_STEP = XT_START / REAL(KTCOUNT) - WRITE(YTCOUNT,FMT="(I0)") KTCOUNT - CALL TIME_STAT_ll(ZTIME_STEP,ZTOT, ' SECOND/STEP='//YTCOUNT,'=') - ! - ! Timing/Step/Points - ! - IPOINTS = NIMAX_ll*NJMAX_ll*NKMAX - WRITE(YPOINTS,FMT="(I0)") IPOINTS - ZTIME_STEP_PTS = ZTIME_STEP / REAL(IPOINTS) * 1e6 - CALL TIME_STAT_ll(ZTIME_STEP_PTS,ZTOT_PT) - CALL TIME_STAT_ll(ZTIME_STEP_PTS,ZTOT_PT, ' MICROSEC/STP/PT='//YPOINTS,'-') - ! - CALL TIMING_SEPARATOR('=') - ! -END IF - -#ifndef MNH_OPENACC -IF ( ASSOCIATED( ZSEA ) ) DEALLOCATE( ZSEA ) -DEALLOCATE( ZRUS,ZRVS,ZRWS ) -DEALLOCATE( ZPABST ) -#else -CALL MNH_MEM_RELEASE() -#endif - -END SUBROUTINE MODEL_n