From 0f865fd4e727130a28b2055a91b1c8a6f9204aef Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 26 Jan 2017 11:12:30 -0700 Subject: [PATCH 01/28] * In ./src/core_atmosphere/physics/physics_wrf/module_sf_bem.F,./module_sf_bep.F, and ./module_sf_bep_bem.F, redefined FATAL_ERROR to physics_error_fatal instead of mpas_dmpar_global_abort. --- src/core_atmosphere/physics/physics_wrf/module_sf_bem.F | 4 ++-- src/core_atmosphere/physics/physics_wrf/module_sf_bep.F | 6 +++--- src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F | 6 +++--- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F index 261956735..544b802f3 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F @@ -3,9 +3,9 @@ MODULE module_sf_bem ! Variables and constants used in the BEM module ! ----------------------------------------------------------------------- -use mpas_abort, only : mpas_dmpar_global_abort #ifdef mpas -#define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) #else #define FATAL_ERROR(M) write(0,*) M ; stop #endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F index 8bf465b46..9434dc8fa 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F @@ -1,9 +1,9 @@ MODULE module_sf_bep -use mpas_abort, only : mpas_dmpar_global_abort #ifdef mpas -#define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) -#else +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else #define FATAL_ERROR(M) write(0,*) M ; stop #endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F index e5c441837..5235fd372 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F @@ -1,9 +1,9 @@ MODULE module_sf_bep_bem -use mpas_abort, only : mpas_dmpar_global_abort #ifdef mpas -#define FATAL_ERROR(M) call mpas_dmpar_global_abort( M ) -#else +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else #define FATAL_ERROR(M) write(0,*) M ; stop #endif From 89cf5a34c1c76127ee4f2e66ee4ca7ec4e4ec9fa Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 26 Jan 2017 16:17:30 -0700 Subject: [PATCH 02/28] * In ./src/core_atmosphere/physics/physics_wrf, replaced calls to wrf_error_fatal with the macro FATAL_ERROR that points to physics_error_fatal in mpas_atmphys_utilities.F. * In ./src/core_atmosphere/physics/physics_wrf/Makefile: -> Removed -I../../../operators -I.. -I../../../external/esmf_time_f90 since those 2 directories are no longer needed to compile physics_wrf. -> Corrected dependencies. --- .../physics/physics_wrf/Makefile | 43 +----- .../physics/physics_wrf/module_cam_support.F | 34 +---- .../physics/physics_wrf/module_ra_rrtmg_lw.F | 14 +- .../physics/physics_wrf/module_ra_rrtmg_sw.F | 30 ++-- .../physics/physics_wrf/module_sf_noahlsm.F | 10 +- .../physics/physics_wrf/module_sf_urban.F | 132 +++++++++--------- 6 files changed, 120 insertions(+), 143 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 68810446e..e908e65f2 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -3,7 +3,7 @@ all: dummy physics_wrf dummy: - echo "****** compile physics_wrf ******" + echo "****** compiling physics_wrf ******" OBJS = \ libmassv.o \ @@ -42,41 +42,17 @@ physics_wrf: $(OBJS) # DEPENDENCIES: module_bl_mynn.o: \ - module_cam_error_function.o \ - ../mpas_atmphys_constants.o + module_cam_error_function.o module_cam_support.o: \ - module_cam_shr_kind_mod.o \ - ../mpas_atmphys_utilities.o - -module_cu_tiedtke.o: \ - ../mpas_atmphys_constants.o - -module_cu_ntiedtke.o: \ - ../mpas_atmphys_constants.o - -module_mp_radar.o: \ - ../mpas_atmphys_functions.o \ - ../mpas_atmphys_utilities.o + module_cam_shr_kind_mod.o module_mp_thompson.o: \ - module_mp_radar.o \ - ../mpas_atmphys_functions.o \ - ../mpas_atmphys_utilities.o + module_mp_radar.o module_ra_cam.o: \ module_cam_support.o \ module_ra_cam_support.o \ - ../mpas_atmphys_utilities.o - -module_ra_cam_support.o: \ - ../mpas_atmphys_utilities.o - -module_ra_rrtmg_lw.o: \ - ../mpas_atmphys_constants.o - -module_ra_rrtmg_sw.o: \ - ../mpas_atmphys_constants.o module_sf_bep.o: \ module_sf_urban.o @@ -87,8 +63,7 @@ module_sf_bep_bem.o: \ module_sf_mynn.o: \ module_bl_mynn.o \ - module_sf_sfclay.o \ - ../mpas_atmphys_constants.o + module_sf_sfclay.o module_sf_noahdrv.o: \ module_sf_bem.o \ @@ -97,10 +72,6 @@ module_sf_noahdrv.o: \ module_sf_noahlsm.o \ module_sf_urban.o -module_sf_noahlsm.o: \ - ../mpas_atmphys_constants.o \ - ../mpas_atmphys_utilities.o - clean: $(RM) *.f90 *.o *.mod @# Certain systems with intel compilers generate *.i files @@ -110,7 +81,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../../framework -I../../../operators -I.. -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../../framework -I../../../operators -I.. -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_cam_support.F b/src/core_atmosphere/physics/physics_wrf/module_cam_support.F index fed7f2674..2f8499e13 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cam_support.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cam_support.F @@ -7,9 +7,12 @@ MODULE module_cam_support ! Author: William.Gustafson@pnl.gov, Nov 2009 !------------------------------------------------------------------------ #if defined(mpas) - use mpas_atmphys_utilities + use mpas_atmphys_utilities,only:physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) #else use module_state_description, only: param_num_moist + use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) #endif use shr_kind_mod @@ -87,28 +90,7 @@ MODULE module_cam_support !!$END FUNCTION cnst_get_type_byind -#if defined(mpas) -!------------------------------------------------------------------------ -SUBROUTINE endrun(msg) -! Pass through routine to wrf_error_fatal that mimics endrun in module -! abortutils of CAM. -! -! Replaces endrun in abortutils module in CAM. -! -! Author: William.Gustafson@pnl.gov, Nov 2009 -! Modified : Balwinder.Singh@pnl.gov - Argument made optional -!------------------------------------------------------------------------ -! Argument of the subroutine is made optional to accomodate endrun calls with no argument - character(len=*), intent(in), optional :: msg - if(present(msg)) then - call physics_error_fatal(msg) - else -! The error message is written to iulog bwfore the endrun call - call physics_error_fatal(iulog) - endif -END SUBROUTINE endrun -#else !------------------------------------------------------------------------ SUBROUTINE endrun(msg) ! Pass through routine to wrf_error_fatal that mimics endrun in module @@ -119,19 +101,17 @@ SUBROUTINE endrun(msg) ! Author: William.Gustafson@pnl.gov, Nov 2009 ! Modified : Balwinder.Singh@pnl.gov - Argument made optional !------------------------------------------------------------------------ - USE module_wrf_error - ! Argument of the subroutine is made optional to accomodate endrun calls with no argument character(len=*), intent(in), optional :: msg if(present(msg)) then - call wrf_error_fatal(msg) + FATAL_ERROR(msg) else ! The error message is written to iulog bwfore the endrun call - call wrf_error_fatal(iulog) + FATAL_ERROR(iulog) endif END SUBROUTINE endrun -#endif + !------------------------------------------------------------------------ diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F index 30d6c014b..b238309d4 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F @@ -2634,6 +2634,15 @@ end module mcica_subcol_gen_lw ! module rrtmg_lw_cldprmc +#if defined(mpas) + use mpas_atmphys_utilities,only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#endif + + ! -------------------------------------------------------------------------- ! | | ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | @@ -2853,7 +2862,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, ciwpmc(ig,lay), radice - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if ncbands = 16 factor = (radice - 2._rb)/3._rb @@ -2875,7 +2884,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, cswpmc(ig,lay), radsno - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if ncbands = 16 factor = (radsno - 2._rb)/3._rb @@ -11420,6 +11429,7 @@ MODULE module_ra_rrtmg_lw #else use module_model_constants, only : cp use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) #if (HWRF == 1) USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF #else diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index 414fc6b41..0f700e355 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -1948,6 +1948,14 @@ end module mcica_subcol_gen_sw module rrtmg_sw_cldprmc +#if defined(mpas) + use mpas_atmphys_utilities,only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#endif + ! -------------------------------------------------------------------------- ! | | ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | @@ -2173,7 +2181,7 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, ciwpmc(ig,lay), radice - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if factor = (radice - 2._rb)/3._rb index = int(factor) @@ -2190,11 +2198,11 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & (fdlice3(index+1,ib) - fdlice3(index,ib)) if (fdelta(ig) .lt. 0.0_rb) then write(errmess, *) 'FDELTA LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (fdelta(ig) .gt. 1.0_rb) then write(errmess, *) 'FDELTA GT THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig) ! See Fu 1996 p. 2067 @@ -2222,7 +2230,7 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & ,ig, lay, cswpmc(ig,lay), radsno - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if factor = (radsno - 2._rb)/3._rb index = int(factor) @@ -2239,11 +2247,11 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & (fdlice3(index+1,ib) - fdlice3(index,ib)) if (fdelta(ig) .lt. 0.0_rb) then write(errmess, *) 'FDELTA LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (fdelta(ig) .gt. 1.0_rb) then write(errmess, *) 'FDELTA GT THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if forwsno(ig) = fdelta(ig) + 0.5_rb / ssacosno(ig) ! See Fu 1996 p. 2067 @@ -2251,23 +2259,23 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & ! Check to ensure all calculated quantities are within physical limits. if (extcosno(ig) .lt. 0.0_rb) then write(errmess, *) 'SNOW EXTINCTION LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (ssacosno(ig) .gt. 1.0_rb) then write(errmess, *) 'SNOW SSA GRTR THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (ssacosno(ig) .lt. 0.0_rb) then write(errmess, *) 'SNOW SSA LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (gsno(ig) .gt. 1.0_rb) then write(errmess, *) 'SNOW ASYM GRTR THAN 1.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if if (gsno(ig) .lt. 0.0_rb) then write(errmess, *) 'SNOW ASYM LESS THAN 0.0' - call wrf_error_fatal(errmess) + FATAL_ERROR(errmess) end if else extcosno(ig) = 0.0_rb diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index c4e680b1e..b5e7504a6 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -3,9 +3,11 @@ MODULE module_sf_noahlsm #if defined(mpas) !MPAS specific (Laura D. Fowler): use mpas_atmphys_constants, rhowater => rho_w -use mpas_atmphys_utilities +use mpas_atmphys_utilities,only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) #else - USE module_model_constants +USE module_model_constants +#define FATAL_ERROR(M) write(0,*) M ; stop #endif !MPAS specific end. @@ -492,7 +494,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ELSE SNDENS = SNEQV / SNOWH IF(SNDENS > 1.0) THEN -! CALL wrf_error_fatal ( 'Physical snow depth is less than snow water equiv.' ) + FATAL_ERROR ( 'Physical snow depth is less than snow water equiv.' ) ENDIF CALL CSNOW (SNCOND,SNDENS) END IF @@ -2419,7 +2421,7 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & IF (NROOT .gt. NSOIL) THEN WRITE (err_message,*) 'Error: too many root layers ', & NSOIL,NROOT -! CALL wrf_error_fatal ( err_message ) + FATAL_ERROR ( err_message ) ! ---------------------------------------------------------------------- ! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM ! DISTRIBUTION BASED ON SOIL LAYER DEPTHS. diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F index 66b38e7db..6502c1186 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F @@ -1,5 +1,12 @@ MODULE module_sf_urban +#ifdef mpas +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else +#define FATAL_ERROR(M) write(0,*) M ; stop +#endif + !=============================================================================== ! Single-Layer Urban Canopy Model for WRF Noah-LSM ! Original Version: 2002/11/06 by Hiroyuki Kusaka @@ -503,8 +510,7 @@ SUBROUTINE urban(LSOLAR, & ! L if(ahoption==1) AH=AH*ahdiuprf(tloc) IF( ZDC+Z0C+2. >= ZA) THEN -! CALL wrf_error_fatal ("ZDC + Z0C + 2m is larger than the 1st WRF level "// & -! "Stop in subroutine urban - change ZDC and Z0C" ) + FATAL_ERROR ("ZDC + Z0C + 2m is larger than the 1st WRF level - Stop in subroutine urban - change ZDC and Z0C" ) END IF IF(.NOT.LSOLAR) THEN @@ -1508,7 +1514,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & IOSTAT=IOSTATUS) IF (IOSTATUS > 0) THEN -! CALL wrf_error_fatal('ERROR OPEN URBPARM.TBL') + FATAL_ERROR('ERROR OPEN URBPARM.TBL') ENDIF READLOOP : do @@ -1525,118 +1531,118 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) icate IF (.not. ALLOCATED(ZR_TBL)) then ALLOCATE( ZR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ZR_TBL in urban_param_init') ALLOCATE( SIGMA_ZED_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0)CALL wrf_error_fatal('Error allocating SIGMA_ZED_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating SIGMA_ZED_TBL in urban_param_init') ALLOCATE( Z0C_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0C_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0C_TBL in urban_param_init') ALLOCATE( Z0HC_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HC_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0HC_TBL in urban_param_init') ALLOCATE( ZDC_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZDC_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ZDC_TBL in urban_param_init') ALLOCATE( SVF_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SVF_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating SVF_TBL in urban_param_init') ALLOCATE( R_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating R_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating R_TBL in urban_param_init') ALLOCATE( RW_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating RW_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating RW_TBL in urban_param_init') ALLOCATE( HGT_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HGT_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HGT_TBL in urban_param_init') ALLOCATE( AH_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AH_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AH_TBL in urban_param_init') ALLOCATE( BETR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETR_TBL in urban_param_init') ALLOCATE( BETB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETB_TBL in urban_param_init') ALLOCATE( BETG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETG_TBL in urban_param_init') ALLOCATE( CAPR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating CAPR_TBL in urban_param_init') ALLOCATE( CAPB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating CAPB_TBL in urban_param_init') ALLOCATE( CAPG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating CAPG_TBL in urban_param_init') ALLOCATE( AKSR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKSR_TBL in urban_param_init') ALLOCATE( AKSB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKSB_TBL in urban_param_init') ALLOCATE( AKSG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKSG_TBL in urban_param_init') ALLOCATE( ALBR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALBR_TBL in urban_param_init') ALLOCATE( ALBB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALBB_TBL in urban_param_init') ALLOCATE( ALBG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALBG_TBL in urban_param_init') ALLOCATE( EPSR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating EPSR_TBL in urban_param_init') ALLOCATE( EPSB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating EPSB_TBL in urban_param_init') ALLOCATE( EPSG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating EPSG_TBL in urban_param_init') ALLOCATE( Z0R_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0R_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0R_TBL in urban_param_init') ALLOCATE( Z0B_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0B_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0B_TBL in urban_param_init') ALLOCATE( Z0G_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0G_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0G_TBL in urban_param_init') ALLOCATE( AKANDA_URBAN_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKANDA_URBAN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating AKANDA_URBAN_TBL in urban_param_init') ALLOCATE( Z0HB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0HB_TBL in urban_param_init') ALLOCATE( Z0HG_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HG_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating Z0HG_TBL in urban_param_init') ALLOCATE( TRLEND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TRLEND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TRLEND_TBL in urban_param_init') ALLOCATE( TBLEND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TBLEND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TBLEND_TBL in urban_param_init') ALLOCATE( TGLEND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TGLEND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TGLEND_TBL in urban_param_init') ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating FRC_URB_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating FRC_URB_TBL in urban_param_init') ! ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) - ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROOF_WIDTH in urban_param_init') ! ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) - ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROAD_WIDTH in urban_param_init') !for BEP ALLOCATE( NUMDIR_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMDIR_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating NUMDIR_TBL in urban_param_init') ALLOCATE( STREET_DIRECTION_TBL(MAXDIRS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_DIRECTION_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating STREET_DIRECTION_TBL in urban_param_init') ALLOCATE( STREET_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_WIDTH_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating STREET_WIDTH_TBL in urban_param_init') ALLOCATE( BUILDING_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BUILDING_WIDTH_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BUILDING_WIDTH_TBL in urban_param_init') ALLOCATE( NUMHGT_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMHGT_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating NUMHGT_TBL in urban_param_init') ALLOCATE( HEIGHT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HEIGHT_BIN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HEIGHT_BIN_TBL in urban_param_init') ALLOCATE( HPERCENT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HPERCENT_BIN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HPERCENT_BIN_TBL in urban_param_init') ALLOCATE( COP_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating COP_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating COP_TBL in urban_param_init') ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PWIN_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating PWIN_TBL in urban_param_init') ALLOCATE( BETA_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETA_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating BETA_TBL in urban_param_init') ALLOCATE( SW_COND_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SW_COND_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating SW_COND_TBL in urban_param_init') ALLOCATE( TIME_ON_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_ON_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TIME_ON_TBL in urban_param_init') ALLOCATE( TIME_OFF_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_OFF_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TIME_OFF_TBL in urban_param_init') ALLOCATE( TARGTEMP_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGTEMP_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TARGTEMP_TBL in urban_param_init') ALLOCATE( GAPTEMP_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPTEMP_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating GAPTEMP_TBL in urban_param_init') ALLOCATE( TARGHUM_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGHUM_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating TARGHUM_TBL in urban_param_init') ALLOCATE( GAPHUM_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPHUM_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating GAPHUM_TBL in urban_param_init') ALLOCATE( PERFLO_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PERFLO_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating PERFLO_TBL in urban_param_init') ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HSESF_TBL in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating HSESF_TBL in urban_param_init') endif numdir_tbl = 0 street_direction_tbl = -1.E36 @@ -1653,12 +1659,12 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) sigma_zed_tbl(1:icate) else if (name == "ROOF_WIDTH") then ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROOF_WIDTH in urban_param_init') read(string(indx+1:),*) roof_width(1:icate) else if (name == "ROAD_WIDTH") then ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) -! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init') + if(allocate_status /= 0) FATAL_ERROR('Error allocating ROAD_WIDTH in urban_param_init') read(string(indx+1:),*) road_width(1:icate) else if (name == "AH") then read(string(indx+1:),*) ah_tbl(1:icate) @@ -1771,7 +1777,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if ( pctsum /= 100.) then write (*,'(//,"Building height percentages for category ", I2, " must sum to 100.0")') k write (*,'("Currently, they sum to ", F6.2,/)') pctsum -! CALL wrf_error_fatal('pctsum is not equal to 100.') + FATAL_ERROR('pctsum is not equal to 100.') endif else if ( name == "Z0R") then read(string(indx+1:),*) Z0R_tbl(1:icate) @@ -1803,7 +1809,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) hsesf_tbl(1:icate) !end BEP else -! CALL wrf_error_fatal('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') + FATAL_ERROR('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') endif enddo READLOOP From 26abae6a44a38873907278cfb3d0385abf7d0ef8 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 7 Feb 2017 20:08:31 +0100 Subject: [PATCH 03/28] Removed whitespace between FATAL_ERROR and opening parenthesis in module_sf_urban.F and module_sf_noahlsm.F as this breaks the preprocessor directive substitution when GEN_F90 is set to true on Mac OS X --- src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F | 4 ++-- src/core_atmosphere/physics/physics_wrf/module_sf_urban.F | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index b5e7504a6..a854f41f8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -494,7 +494,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ELSE SNDENS = SNEQV / SNOWH IF(SNDENS > 1.0) THEN - FATAL_ERROR ( 'Physical snow depth is less than snow water equiv.' ) + FATAL_ERROR( 'Physical snow depth is less than snow water equiv.' ) ENDIF CALL CSNOW (SNCOND,SNDENS) END IF @@ -2421,7 +2421,7 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & IF (NROOT .gt. NSOIL) THEN WRITE (err_message,*) 'Error: too many root layers ', & NSOIL,NROOT - FATAL_ERROR ( err_message ) + FATAL_ERROR( err_message ) ! ---------------------------------------------------------------------- ! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM ! DISTRIBUTION BASED ON SOIL LAYER DEPTHS. diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F index 6502c1186..d2ac6a0b4 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F @@ -510,7 +510,7 @@ SUBROUTINE urban(LSOLAR, & ! L if(ahoption==1) AH=AH*ahdiuprf(tloc) IF( ZDC+Z0C+2. >= ZA) THEN - FATAL_ERROR ("ZDC + Z0C + 2m is larger than the 1st WRF level - Stop in subroutine urban - change ZDC and Z0C" ) + FATAL_ERROR("ZDC + Z0C + 2m is larger than the 1st WRF level - Stop in subroutine urban - change ZDC and Z0C" ) END IF IF(.NOT.LSOLAR) THEN From e33486810206bbe93bd958f04ea63e89d2575535 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Fri, 27 Jan 2017 11:04:41 -0700 Subject: [PATCH 04/28] * In ./src/core_atmosphere/physics/physics_wrf, added the module module_ra_rrtmg_vinterp.F which only contains the subroutine vinterp_ozn, previously in ./physics/mpas_atmphys_o3climatology.F. This removes the conflict of compiling mpas_atmphys_o3climatology.F in OBJS_init prior to compiling module_ra_cam_support in core_physics_wrf (see ./physics/Makefile). -> In module_ra_rrmtg_lw.F, substituted "use mpas_atmphys_o3climatology" with "use module_ra_rrtmg_vinterp" at the top of module module_ra_rrtmg_lw. -> In module_ra_rrmtg_sw.F, substituted "use mpas_atmphys_o3climatology" with "use module_ra_rrtmg_vinterp" at the top of module module_ra_rrtmg_sw. -> In mpas_atmphys_o3climatology.F, removed the subroutine vinterp_ozn. -> In mpas_atmphys_driver_radiation_lw.F, substituted "use mpas_atmphys_o3climatology" with "use module_ra_rrtmg_vinterp". Also removed "use mpas_derived_types" since it is not needed. -> Modified Makefile accordingly. --- .../mpas_atmphys_driver_radiation_lw.F | 4 +- .../physics/mpas_atmphys_o3climatology.F | 165 +--------------- .../physics/physics_wrf/Makefile | 9 +- .../physics/physics_wrf/module_ra_rrtmg_lw.F | 4 +- .../physics/physics_wrf/module_ra_rrtmg_sw.F | 4 +- .../physics_wrf/module_ra_rrtmg_vinterp.F | 180 ++++++++++++++++++ 6 files changed, 196 insertions(+), 170 deletions(-) create mode 100644 src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 52e841d4c..0268066e8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -9,12 +9,11 @@ module mpas_atmphys_driver_radiation_lw use mpas_kind_types use mpas_pool_routines - use mpas_derived_types +!use mpas_derived_types use mpas_atmphys_driver_radiation_sw, only: radconst use mpas_atmphys_constants use mpas_atmphys_manager, only: gmt,curr_julday,julday,year - use mpas_atmphys_o3climatology, only: vinterp_ozn use mpas_atmphys_camrad_init use mpas_atmphys_rrtmg_lwinit use mpas_atmphys_vars @@ -22,6 +21,7 @@ module mpas_atmphys_driver_radiation_lw !wrf physics: use module_ra_cam use module_ra_rrtmg_lw + use module_ra_rrtmg_vinterp implicit none private diff --git a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F index bcad245ae..934ffe7be 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F +++ b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F @@ -8,7 +8,7 @@ !================================================================================================================= module mpas_atmphys_o3climatology use mpas_kind_types - use mpas_derived_types +!use mpas_derived_types use mpas_pool_routines use mpas_atmphys_date_time use mpas_atmphys_constants @@ -21,8 +21,7 @@ module mpas_atmphys_o3climatology private public:: init_o3climatology, & update_o3climatology, & - o3climatology_from_MPAS, & - vinterp_ozn + o3climatology_from_MPAS integer,parameter:: latsiz = 64 integer,parameter:: lonsiz = 1 @@ -42,8 +41,6 @@ module mpas_atmphys_o3climatology ! as done for the greeness fraction in the MPAS time manager. ! o3climatology_from_MPAS: interpolates the ozone volume mixing ratio to the current Julian day ! as in the CAM radiation codes. -! vinterp_ozn : vertical interpolation of the ozone volume mixing ratios from fixed -! ozone pressure levels to the MPAS pressure levels. ! ! add-ons and modifications to sourcecode: ! ---------------------------------------- @@ -328,164 +325,6 @@ subroutine o3climatology_from_MPAS(julian,mesh,atm_input,diag_physics) end subroutine o3climatology_from_MPAS -!================================================================================================================= - subroutine vinterp_ozn (lchnk, ncol, pcols, pver, pmid_in, pin_in, levsiz, ozmix_in, o3vmr_out) -!-------------------------------------------------------------------------------------------------- -! -! Purpose: Interpolate ozone from current time-interpolated values to model levels -! -! Method: Use pressure values to determine interpolation levels -! -! Author: Bruce Briegleb -! -!----------------------------------------------------------------------------------------------------------------- -! use shr_kind_mod, only: r8 => shr_kind_r8 -! use ppgrid -! use phys_grid, only: get_lat_all_p, get_lon_all_p -! use comozp -! use abortutils, only: endrun -!----------------------------------------------------------------------------------------------------------------- - implicit none -!----------------------------------------------------------------------------------------------------------------- -! -! Arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: pcols, pver - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: levsiz ! number of ozone layers - -!ldf begin: -! real(kind=RKIND), intent(in) :: pmid(pcols,pver) ! level pressures (mks) -! real(kind=RKIND), intent(in) :: pin(levsiz) ! ozone data level pressures (mks) -! real(kind=RKIND), intent(in) :: ozmix(pcols,levsiz)! ozone mixing ratio - -! real(kind=RKIND), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio - - real(kind=RKIND), intent(in) :: pmid_in(pcols,pver) ! level pressures (mks) - real(kind=RKIND), intent(in) :: pin_in(levsiz) ! ozone data level pressures (mks) - real(kind=RKIND), intent(in) :: ozmix_in(pcols,levsiz)! ozone mixing ratio - - real(kind=RKIND), intent(out) :: o3vmr_out(pcols,pver)! ozone volume mixing ratio -!ldf end. -! -! local storage -! - integer i ! longitude index - integer k, kk, kkstart ! level indices - integer kupper(pcols) ! Level indices for interpolation - integer kount ! Counter - integer lats(pcols) ! latitude indices - integer lons(pcols) ! latitude indices - - real(kind=RKIND) dpu ! upper level pressure difference - real(kind=RKIND) dpl ! lower level pressure difference - -!ldf begin: - real(kind=RKIND):: pmid(pcols,pver) ! level pressures (mks) - real(kind=RKIND):: pin(levsiz) ! ozone data level pressures (mks) - real(kind=RKIND):: ozmix(pcols,levsiz) ! ozone mixing ratio - real(kind=RKIND):: o3vmr(pcols,pver) ! ozone volume mixing ratio -! -! Initialize latitude indices -! -! call get_lat_all_p(lchnk, ncol, lats) -! call get_lon_all_p(lchnk, ncol, lons) -! - -!ldf begin: - do k = 1,levsiz - pin(k) = pin_in(k) - enddo - do i = 1,pcols - do k = 1,levsiz - ozmix(i,k) = ozmix_in(i,k) - enddo - enddo - do i = 1,pcols - do k = 1,pver - kk = pver-k+1 - pmid(i,kk) = pmid_in(i,k) - enddo - enddo -!ldf end. - -! Initialize index array -! - do i=1,ncol - kupper(i) = 1 - end do - - do k=1,pver -! -! Top level we need to start looking is the top level for the previous k -! for all longitude points -! - kkstart = levsiz - do i=1,ncol - kkstart = min0(kkstart,kupper(i)) - end do - kount = 0 -! -! Store level indices for interpolation -! - do kk=kkstart,levsiz-1 - do i=1,ncol - if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then - kupper(i) = kk - kount = kount + 1 - end if - end do -! -! If all indices for this level have been found, do the interpolation and -! go to the next level -! - if (kount.eq.ncol) then - do i=1,ncol - dpu = pmid(i,k) - pin(kupper(i)) - dpl = pin(kupper(i)+1) - pmid(i,k) - o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & - ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) - end do - goto 35 - end if - end do -! -! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and -! must extrapolate from the bottom or top ozone data level for at least some -! of the longitude points. -! - do i=1,ncol - if (pmid(i,k) .lt. pin(1)) then - o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1) - else if (pmid(i,k) .gt. pin(levsiz)) then - o3vmr(i,k) = ozmix(i,levsiz) - else - dpu = pmid(i,k) - pin(kupper(i)) - dpl = pin(kupper(i)+1) - pmid(i,k) - o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & - ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) - end if - end do - - if (kount.gt.ncol) then -! call endrun ('VINTERP_OZN: Bad ozone data: non-monotonicity suspected') - end if -35 continue - end do - -!ldf begin: - do i = 1,pcols - do k = 1,pver - kk = pver-k+1 - o3vmr_out(i,kk) = o3vmr(i,k) - enddo - enddo -!ldf end. - - return -end subroutine vinterp_ozn - !================================================================================================================= end module mpas_atmphys_o3climatology !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index e908e65f2..80b682701 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -26,6 +26,7 @@ OBJS = \ module_ra_cam_support.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ + module_ra_rrtmg_vinterp.o \ module_sf_bem.o \ module_sf_bep.o \ module_sf_bep_bem.o \ @@ -52,7 +53,13 @@ module_mp_thompson.o: \ module_ra_cam.o: \ module_cam_support.o \ - module_ra_cam_support.o \ + module_ra_cam_support.o + +module_ra_rrtmg_lw.o: \ + module_ra_rrtmg_vinterp.o + +module_ra_rrtmg_sw.o: \ + module_ra_rrtmg_vinterp.o module_sf_bep.o: \ module_sf_urban.o diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F index b238309d4..6d59bcb82 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_lw.F @@ -11391,8 +11391,8 @@ MODULE module_ra_rrtmg_lw #if defined(mpas) !MPAS specific (Laura D. Fowler): -use mpas_atmphys_constants,only: cp,g=>gravity -use mpas_atmphys_o3climatology,only: vinterp_ozn +use mpas_atmphys_constants,only : cp,g=>gravity +use module_ra_rrtmg_vinterp,only: vinterp_ozn !> add-ons and modifications to sourcecode: !> ---------------------------------------- diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index 0f700e355..a2ee96b62 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -9818,8 +9818,8 @@ MODULE module_ra_rrtmg_sw #if defined(mpas) !MPAS specific (Laura D. Fowler): -use mpas_atmphys_constants,only: cp,g=>gravity -use mpas_atmphys_o3climatology,only: vinterp_ozn +use mpas_atmphys_constants,only : cp,g=>gravity +use module_ra_rrtmg_vinterp,only: vinterp_ozn !> add-ons and modifications to sourcecode: !> ---------------------------------------- diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F new file mode 100644 index 000000000..8a77e87c0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F @@ -0,0 +1,180 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module module_ra_rrtmg_vinterp + use mpas_kind_types + + implicit none + private + public:: vinterp_ozn + + + contains + + +!================================================================================================================= + subroutine vinterp_ozn (lchnk, ncol, pcols, pver, pmid_in, pin_in, levsiz, ozmix_in, o3vmr_out) +!-------------------------------------------------------------------------------------------------- +! +! Purpose: Interpolate ozone from current time-interpolated values to model levels +! +! Method: Use pressure values to determine interpolation levels +! +! Author: Bruce Briegleb +! +!----------------------------------------------------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use phys_grid, only: get_lat_all_p, get_lon_all_p +! use comozp +! use abortutils, only: endrun +!----------------------------------------------------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: pcols, pver + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: levsiz ! number of ozone layers + +!ldf begin: +! real(kind=RKIND), intent(in) :: pmid(pcols,pver) ! level pressures (mks) +! real(kind=RKIND), intent(in) :: pin(levsiz) ! ozone data level pressures (mks) +! real(kind=RKIND), intent(in) :: ozmix(pcols,levsiz)! ozone mixing ratio + +! real(kind=RKIND), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio + + real(kind=RKIND), intent(in) :: pmid_in(pcols,pver) ! level pressures (mks) + real(kind=RKIND), intent(in) :: pin_in(levsiz) ! ozone data level pressures (mks) + real(kind=RKIND), intent(in) :: ozmix_in(pcols,levsiz)! ozone mixing ratio + + real(kind=RKIND), intent(out) :: o3vmr_out(pcols,pver)! ozone volume mixing ratio +!ldf end. +! +! local storage +! + integer i ! longitude index + integer k, kk, kkstart ! level indices + integer kupper(pcols) ! Level indices for interpolation + integer kount ! Counter + integer lats(pcols) ! latitude indices + integer lons(pcols) ! latitude indices + + real(kind=RKIND) dpu ! upper level pressure difference + real(kind=RKIND) dpl ! lower level pressure difference + +!ldf begin: + real(kind=RKIND):: pmid(pcols,pver) ! level pressures (mks) + real(kind=RKIND):: pin(levsiz) ! ozone data level pressures (mks) + real(kind=RKIND):: ozmix(pcols,levsiz) ! ozone mixing ratio + real(kind=RKIND):: o3vmr(pcols,pver) ! ozone volume mixing ratio +! +! Initialize latitude indices +! +! call get_lat_all_p(lchnk, ncol, lats) +! call get_lon_all_p(lchnk, ncol, lons) +! + +!ldf begin: + do k = 1,levsiz + pin(k) = pin_in(k) + enddo + do i = 1,pcols + do k = 1,levsiz + ozmix(i,k) = ozmix_in(i,k) + enddo + enddo + do i = 1,pcols + do k = 1,pver + kk = pver-k+1 + pmid(i,kk) = pmid_in(i,k) + enddo + enddo +!ldf end. + +! Initialize index array +! + do i=1,ncol + kupper(i) = 1 + end do + + do k=1,pver +! +! Top level we need to start looking is the top level for the previous k +! for all longitude points +! + kkstart = levsiz + do i=1,ncol + kkstart = min0(kkstart,kupper(i)) + end do + kount = 0 +! +! Store level indices for interpolation +! + do kk=kkstart,levsiz-1 + do i=1,ncol + if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then + kupper(i) = kk + kount = kount + 1 + end if + end do +! +! If all indices for this level have been found, do the interpolation and +! go to the next level +! + if (kount.eq.ncol) then + do i=1,ncol + dpu = pmid(i,k) - pin(kupper(i)) + dpl = pin(kupper(i)+1) - pmid(i,k) + o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & + ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) + end do + goto 35 + end if + end do +! +! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and +! must extrapolate from the bottom or top ozone data level for at least some +! of the longitude points. +! + do i=1,ncol + if (pmid(i,k) .lt. pin(1)) then + o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1) + else if (pmid(i,k) .gt. pin(levsiz)) then + o3vmr(i,k) = ozmix(i,levsiz) + else + dpu = pmid(i,k) - pin(kupper(i)) + dpl = pin(kupper(i)+1) - pmid(i,k) + o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & + ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) + end if + end do + + if (kount.gt.ncol) then +! call endrun ('VINTERP_OZN: Bad ozone data: non-monotonicity suspected') + end if +35 continue + end do + +!ldf begin: + do i = 1,pcols + do k = 1,pver + kk = pver-k+1 + o3vmr_out(i,kk) = o3vmr(i,k) + enddo + enddo +!ldf end. + + return +end subroutine vinterp_ozn + +!================================================================================================================= + end module module_ra_rrtmg_vinterp +!================================================================================================================= From 3e558b8ffbb8db89af081d63bfe0eeeb25df1661 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Fri, 10 Feb 2017 10:16:27 -0700 Subject: [PATCH 05/28] * In ./src/core_atmosphere/physics/physics_wrf, added comments at the top of module module_ra_rrtmg_vinterp.F. These comments clarify the origin of the subroutine vinterp_ozn, and the need to add module_ra_rrtmg_vinterp.F in physics_wrf. --- .../physics/physics_wrf/module_ra_rrtmg_vinterp.F | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F index 8a77e87c0..6ec6c41cc 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_vinterp.F @@ -1,10 +1,11 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! +!================================================================================================================= +!in module_ra_rrtmg_vinterp, the subroutine vinterp_ozn was originally the same as subroutine radozn and copied +!from module_ra_cam.F. module_ra_cam.F was itself copied from WRF 3.3.0. + +!subroutine vinterp_ozn is called from the subroutines rrtmg_lwrad (in module_ra_rrtmg_lw.F) and rrtmg_swrad (in +!module_ra_rrtmg_sw.F) for interpolation of climatological ozone onto the MPAS pressure levels. vinterp_ozn is +!also called from subroutine radiation_lw_from_MPAS (in mpas_atmphys_driver_radiation_lw.F) for diagnostic only. +!Laura D. Fowler (laura@ucar.edu)/2017-02-10. !================================================================================================================= module module_ra_rrtmg_vinterp use mpas_kind_types From 4f8289261f876f7a6d7828ea439188b405c867c2 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Fri, 27 Jan 2017 11:37:54 -0700 Subject: [PATCH 06/28] * In ./src/core_atmosphere/physics modules where we had the two use statements "use mpas_derived_types" and "use mpas_pool_routines", removed "use mpas_derived_types" which is not needed. * In ./src/core_atmosphere/Makefile: -> Cleaned up all the dependencies. -> Moved compiling mpas_atmphys_o3climatology.F from OBJS_init to OBJS. -> Removed the include -I../../operators which is not needed. --- src/core_atmosphere/physics/Makefile | 79 ++++++------------- .../physics/mpas_atmphys_camrad_init.F | 1 - .../physics/mpas_atmphys_control.F | 1 - .../physics/mpas_atmphys_driver.F | 1 - .../physics/mpas_atmphys_driver_cloudiness.F | 1 - .../physics/mpas_atmphys_driver_convection.F | 1 - .../physics/mpas_atmphys_driver_gwdo.F | 1 - .../physics/mpas_atmphys_driver_lsm.F | 1 - .../mpas_atmphys_driver_microphysics.F | 1 - .../physics/mpas_atmphys_driver_oml.F | 1 - .../physics/mpas_atmphys_driver_pbl.F | 1 - .../mpas_atmphys_driver_radiation_lw.F | 4 +- .../mpas_atmphys_driver_radiation_sw.F | 1 - .../physics/mpas_atmphys_driver_sfclayer.F | 1 - .../physics/mpas_atmphys_finalize.F | 1 - .../physics/mpas_atmphys_init.F | 1 - .../physics/mpas_atmphys_init_microphysics.F | 1 - .../physics/mpas_atmphys_initialize_real.F | 1 - .../physics/mpas_atmphys_interface.F | 1 - .../physics/mpas_atmphys_landuse.F | 1 - .../physics/mpas_atmphys_lsm_noahinit.F | 1 - .../physics/mpas_atmphys_manager.F | 1 - .../physics/mpas_atmphys_o3climatology.F | 3 +- .../physics/mpas_atmphys_todynamics.F | 1 - .../physics/mpas_atmphys_update.F | 1 - .../physics/mpas_atmphys_update_surface.F | 1 - 26 files changed, 28 insertions(+), 81 deletions(-) diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 8aa3ca304..41fc9b1d2 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,15 +4,16 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif +all: lookup_tables core_physics_init core_physics_wrf core_dyn core_physics + dummy: - echo "****** make non-hydrostatic core ******" + echo "****** compiling physics ******" OBJS_init = \ mpas_atmphys_constants.o \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ - mpas_atmphys_utilities.o \ - mpas_atmphys_o3climatology.o + mpas_atmphys_utilities.o OBJS = \ mpas_atmphys_camrad_init.o \ @@ -23,6 +24,7 @@ OBJS = \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_microphysics.o \ + mpas_atmphys_driver_oml.o \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ @@ -33,7 +35,7 @@ OBJS = \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ mpas_atmphys_manager.o \ - mpas_atmphys_driver_oml.o \ + mpas_atmphys_o3climatology.o \ mpas_atmphys_packages.o \ mpas_atmphys_rrtmg_lwinit.o \ mpas_atmphys_rrtmg_swinit.o \ @@ -44,8 +46,6 @@ OBJS = \ OBJS_dyn = mpas_atmphys_interface.o -all: lookup_tables core_physics_init core_physics_wrf core_dyn core_physics - lookup_tables: ./checkout_data_files.sh @@ -64,8 +64,7 @@ core_physics: $(OBJS) # DEPENDENCIES: mpas_atmphys_camrad_init.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_cam_support.o + mpas_atmphys_utilities.o mpas_atmphys_control.o: \ mpas_atmphys_utilities.o \ @@ -88,54 +87,35 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_cloudiness.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_mp_thompson_cldfra3.o + mpas_atmphys_vars.o mpas_atmphys_driver_convection.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_cu_gf.mpas.o \ - ./physics_wrf/module_cu_kfeta.o \ - ./physics_wrf/module_cu_tiedtke.o \ - ./physics_wrf/module_cu_ntiedtke.o - -mpas_atmphys_finalize.o: \ - ./physics_wrf/module_mp_thompson.o - -mpas_atmphys_finalize.o: \ - ./physics_wrf/module_mp_thompson.o + mpas_atmphys_vars.o mpas_atmphys_driver_gwdo.o: \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_bl_gwdo.o + mpas_atmphys_vars.o mpas_atmphys_driver_lsm.o: \ mpas_atmphys_constants.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_sf_noahdrv.o + mpas_atmphys_vars.o mpas_atmphys_driver_microphysics.o: \ mpas_atmphys_constants.o \ mpas_atmphys_init_microphysics.o \ mpas_atmphys_interface.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_mp_kessler.o \ - ./physics_wrf/module_mp_thompson.o \ - ./physics_wrf/module_mp_wsm6.o + mpas_atmphys_vars.o mpas_atmphys_driver_oml.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_sf_oml.o + mpas_atmphys_vars.o mpas_atmphys_driver_pbl.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_bl_mynn.o \ - ./physics_wrf/module_bl_ysu.o + mpas_atmphys_vars.o mpas_atmphys_driver_radiation_lw.o: \ mpas_atmphys_camrad_init.o \ @@ -143,24 +123,18 @@ mpas_atmphys_driver_radiation_lw.o: \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_manager.o \ mpas_atmphys_rrtmg_lwinit.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_ra_cam.o \ - ./physics_wrf/module_ra_rrtmg_lw.o + mpas_atmphys_vars.o mpas_atmphys_driver_radiation_sw.o: \ mpas_atmphys_camrad_init.o \ mpas_atmphys_constants.o \ mpas_atmphys_manager.o \ mpas_atmphys_rrtmg_swinit.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_ra_cam.o \ - ./physics_wrf/module_ra_rrtmg_sw.o + mpas_atmphys_vars.o mpas_atmphys_driver_sfclayer.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_vars.o \ - ./physics_wrf/module_sf_mynn.o \ - ./physics_wrf/module_sf_sfclay.o + mpas_atmphys_vars.o mpas_atmphys_init.o: \ mpas_atmphys_driver_convection.o \ @@ -172,9 +146,6 @@ mpas_atmphys_init.o: \ mpas_atmphys_landuse.o \ mpas_atmphys_o3climatology.o -mpas_atmphys_init_microphysics.o: \ - ./physics_wrf/module_mp_thompson.o - mpas_atmphys_interface.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o @@ -185,8 +156,7 @@ mpas_atmphys_landuse.o: \ mpas_atmphys_lsm_noahinit.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_sf_noahlsm.o + mpas_atmphys_utilities.o mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ @@ -198,18 +168,15 @@ mpas_atmphys_manager.o: \ mpas_atmphys_o3climatology.o: \ mpas_atmphys_date_time.o \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_cam_support.o + mpas_atmphys_utilities.o mpas_atmphys_rrtmg_lwinit.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_rrtmg_lw.o + mpas_atmphys_utilities.o mpas_atmphys_rrtmg_swinit.o: \ mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - ./physics_wrf/module_ra_rrtmg_sw.o + mpas_atmphys_utilities.o mpas_atmphys_todynamics.o: \ mpas_atmphys_constants.o \ @@ -236,7 +203,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I./physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I./physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F index 3b58a1c9d..93e211bc6 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F @@ -15,7 +15,6 @@ module mpas_atmphys_camrad_init use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants,only: cp,degrad,ep_2,gravity,R_d,R_v,stbolt diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 4ad78ce79..f34c6d8d4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -9,7 +9,6 @@ module mpas_atmphys_control use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_utilities diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 5548aad2b..5ebdaeb28 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_driver_cloudiness diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F index 077ddf416..54825d699 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_cloudiness use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants, only: ep_2 diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index fbc792687..0146e350b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_convection use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index 1e5f2dbf9..82f56f56d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_gwdo use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index fd018dfae..2e7e947a0 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_lsm use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 4c4ad1fa7..6213dcc6a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_microphysics use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F index bba081b20..18b791d3b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_oml use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 2b3a15a7a..4f8f39f6c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_pbl use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 0268066e8..9d2159bcf 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -9,7 +9,6 @@ module mpas_atmphys_driver_radiation_lw use mpas_kind_types use mpas_pool_routines -!use mpas_derived_types use mpas_atmphys_driver_radiation_sw, only: radconst use mpas_atmphys_constants @@ -82,6 +81,9 @@ module mpas_atmphys_driver_radiation_lw ! * in the call to rrtmg_lwrad, substituted the variables qv_p, qc_p, qi_p, and qs_p with qvrad_p, qcrad_p, ! qirad_p, and qsrad_p initialized in subroutine cloudiness_from_MPAS. ! Laura D. Fowler (laura@ucar.edu) / 2016-07-09. +! * substituted "use mpas_atmphys_o3climatology" with "use module_ra_rrtmg_vinterp" since we moved subroutine +! vinterp_ozn to is own module in physics_wrf. +! laura D. Fowler (laura@ucar.edu) / 2017-01-27. contains diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index d04c90f70..143ba5933 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_radiation_sw use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index fc2832db1..e245a8e1a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_driver_sfclayer use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index 81d383291..99fdcc84b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -7,7 +7,6 @@ ! !================================================================================================================= module mpas_atmphys_finalize - use mpas_derived_types use mpas_pool_routines use module_mp_thompson diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index aefcbd4b7..26931649a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_init use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_timekeeping diff --git a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F index e2a93876a..b01a60b97 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F @@ -10,7 +10,6 @@ module mpas_atmphys_init_microphysics use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_utilities diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index ba983bf45..e3f0ca49c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -9,7 +9,6 @@ module mpas_atmphys_initialize_real use mpas_kind_types use mpas_dmpar - use mpas_derived_types use mpas_pool_routines use mpas_init_atm_surface diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 06b0e972e..92da27b0b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_interface use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_landuse.F b/src/core_atmosphere/physics/mpas_atmphys_landuse.F index 6d6f7f3d4..74588a9c8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_landuse.F +++ b/src/core_atmosphere/physics/mpas_atmphys_landuse.F @@ -13,7 +13,6 @@ module mpas_atmphys_landuse use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_utilities diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F index e2e25090b..82ca1e35d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F @@ -15,7 +15,6 @@ module mpas_atmphys_lsm_noahinit use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_constants diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index f553da6a5..d84fb3ead 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_manager use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_timekeeping use mpas_stream_manager diff --git a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F index 934ffe7be..fbb6899d2 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F +++ b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_o3climatology use mpas_kind_types -!use mpas_derived_types use mpas_pool_routines use mpas_atmphys_date_time use mpas_atmphys_constants @@ -48,6 +47,8 @@ module mpas_atmphys_o3climatology ! Laura D. Fowler (laura@ucar.edu) / 2014-04-22. ! * modified sourcecode to use pools. ! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +! * moved the subroutine vinterp_ozn to its own module module_ra_rrtmg_vinterp.F in physics_wrf. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-27. contains diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 1627e686c..a7ce596be 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_todynamics use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_dmpar diff --git a/src/core_atmosphere/physics/mpas_atmphys_update.F b/src/core_atmosphere/physics/mpas_atmphys_update.F index 2b067fdad..5425a9064 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update.F @@ -8,7 +8,6 @@ !================================================================================================================= module mpas_atmphys_update use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_driver_convection diff --git a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F index 858283778..06742e08c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F @@ -9,7 +9,6 @@ module mpas_atmphys_update_surface use mpas_dmpar use mpas_kind_types - use mpas_derived_types use mpas_pool_routines use mpas_atmphys_date_time From 00829fcc87e586f05be315287b62f01954cf48aa Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Fri, 10 Feb 2017 15:32:20 -0700 Subject: [PATCH 07/28] * In ./src/core_atmosphere/physics/Makefile: -> moved mpas_atmphys_interface.o from OBJS_dyn to OBJS. I recall that originally, we used OBJS_dyn to handle separate interfaces between the dynamics and physics when we had the hydrostatic and non-hydrostatic dynamical cores. Now that we only run the non-hydrostatic dynamicol core, we can simplify Makefile. -> consequently, also removed core_dyn. --- src/core_atmosphere/physics/Makefile | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 41fc9b1d2..dcaf41f95 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,7 +4,7 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif -all: lookup_tables core_physics_init core_physics_wrf core_dyn core_physics +all: lookup_tables core_physics_init core_physics_wrf core_physics dummy: echo "****** compiling physics ******" @@ -32,6 +32,7 @@ OBJS = \ mpas_atmphys_finalize.o \ mpas_atmphys_init.o \ mpas_atmphys_init_microphysics.o \ + mpas_atmphys_interface.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ mpas_atmphys_manager.o \ @@ -44,17 +45,12 @@ OBJS = \ mpas_atmphys_update.o \ mpas_atmphys_vars.o -OBJS_dyn = mpas_atmphys_interface.o - lookup_tables: ./checkout_data_files.sh core_physics_wrf: (cd physics_wrf; make all COREDEF="$(COREDEF)") -core_dyn: $(OBJS_dyn) - ar -ru libphys.a $(OBJS_dyn) - core_physics_init: $(OBJS_init) ar -ru libphys.a $(OBJS_init) From 31d01360f5162af12e311727fc5e6cd25535ed2d Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Tue, 14 Feb 2017 09:26:08 -0700 Subject: [PATCH 08/28] * In ./src/core_atmosphere/physics/physics_wrf/Makefile, corrected the dependencies for module_ra_rrtmg_sw.o. --- src/core_atmosphere/physics/physics_wrf/Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 80b682701..3250ebaff 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -59,6 +59,7 @@ module_ra_rrtmg_lw.o: \ module_ra_rrtmg_vinterp.o module_ra_rrtmg_sw.o: \ + module_ra_rrtmg_lw.o \ module_ra_rrtmg_vinterp.o module_sf_bep.o: \ From 8737b0975e521187b7090f1e77547989f29554c6 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Tue, 14 Feb 2017 09:27:47 -0700 Subject: [PATCH 09/28] * In ./src/core_atmosphere/physics/physics_wrf: -> In module_mp_thompson.F, specify that the functions gammp,wgamma,rslf,and rsif are the only functions to used from mpas_atmphys_functions. -> In module_mp_thompson_cdfra3.F, now use mpas_atmphys_functions instead of use module_mp_thompson since we only want to use the functions rslf and rsif from mpas_atmphys_functions. --- src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F | 2 +- .../physics/physics_wrf/module_mp_thompson_cldfra3.F | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F index f027f56d1..2aab7fb72 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F @@ -61,7 +61,7 @@ MODULE module_mp_thompson use mpas_kind_types - use mpas_atmphys_functions + use mpas_atmphys_functions, only: gammp,wgamma,rslf,rsif use mpas_atmphys_utilities use module_mp_radar diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F index bb5ded6e2..bf47aae2e 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_cldfra3.F @@ -14,6 +14,7 @@ module module_mp_thompson_cldfra3 ! than the model-top index. ! Laura D. Fowler (laura@ucar.edu)/2016-09-23. + use mpas_atmphys_functions,only: rslf,rsif implicit none private @@ -47,8 +48,8 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte) ! - USE module_mp_thompson , ONLY : rsif, rslf - IMPLICIT NONE +! USE module_mp_thompson , ONLY : rsif, rslf +! IMPLICIT NONE ! INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & From f3835203a3c45bb8c8fb087ff4f2e1ab111c7419 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 09:11:58 -0700 Subject: [PATCH 10/28] * In ./src/core_atmosphere/physics, removed the local variable gwdo_scheme originally defined in mpas_atmphys_vars.F. gwdo_scheme is no longer needed and can be replaced with config_gwdo_scheme. --- src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F | 4 ++++ src/core_atmosphere/physics/mpas_atmphys_manager.F | 8 ++++---- src/core_atmosphere/physics/mpas_atmphys_vars.F | 4 +++- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index 82f56f56d..ec720a93a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -266,6 +266,8 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic type(mpas_pool_type),intent(inout):: tend_physics !local variables: + character(len=StrKIND),pointer:: gwdo_scheme + integer:: i,iCell,iEdge real(kind=RKIND),dimension(:),allocatable:: dx_max @@ -273,6 +275,8 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic !write(0,*) !write(0,*) '--- enter subroutine driver_gwdo:' + call mpas_pool_get_config(configs,'config_gwdo_scheme',gwdo_scheme) + !copy MPAS arrays to local arrays: call gwdo_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index d84fb3ead..a817e1ca3 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -96,7 +96,10 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. ! * added initialization of variables has_reqc,has_reqi,and has_reqs needed in the calls to radiation codes ! rrtmg_lwrad and rrmtg_swrad. -! Laura D. Fowler (laura@ucar.edu) / 2016-07-007. +! Laura D. Fowler (laura@ucar.edu) / 2016-07-07. +! * in subroutine physics_run_init, removed the initialization of the local variable gwdo_scheme. gwdo_scheme +! is no longer needed and can be replaced with config_gwdo_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2016-02-16. contains @@ -357,7 +360,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !local pointers: character(len=StrKIND),pointer:: config_convection_scheme, & - config_gwdo_scheme, & config_lsm_scheme, & config_microp_scheme, & config_pbl_scheme, & @@ -397,7 +399,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !write(0,*) '--- enter subroutine physics_run_init:' call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) - call mpas_pool_get_config(configs,'config_gwdo_scheme' ,config_gwdo_scheme ) call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) @@ -665,7 +666,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) lsm_scheme = trim(config_lsm_scheme) microp_scheme = trim(config_microp_scheme) pbl_scheme = trim(config_pbl_scheme) - gwdo_scheme = trim(config_gwdo_scheme) radt_cld_scheme = trim(config_radt_cld_scheme) radt_lw_scheme = trim(config_radt_lw_scheme) radt_sw_scheme = trim(config_radt_sw_scheme) diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index bdd26ce10..9cec70258 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -68,6 +68,9 @@ module mpas_atmphys_vars ! * moved the declarations of arrays delta_p,wstar_p,uoce_p,and voce_p since they are now used in both modules ! module_bl_ysu.F and module_bl_mynn.F. ! Laura D. Fowler (laura@ucar.edu) / 20016-10-27. +! * removed the initialization local variable gwdo_scheme. gwdo_scheme is no longer needed and can be replaced +! with config_gwdo_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2016-02-16. !================================================================================================================= @@ -76,7 +79,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: microp_scheme character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: gwdo_scheme character(len=StrKIND),public:: lsm_scheme character(len=StrKIND),public:: pbl_scheme character(len=StrKIND),public:: radt_cld_scheme From c9ebfc891602631c4b1f0440cd8c427e699a61f9 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 09:38:12 -0700 Subject: [PATCH 11/28] * In ./src/core_atmosphere/physics, removed the local variable lsm_scheme originally defined in mpas_atmphys_vars.F. lsm_scheme is no longer needed and can be replaced with config_lsm_scheme. --- .../physics/mpas_atmphys_driver_lsm.F | 14 ++++++++++++-- src/core_atmosphere/physics/mpas_atmphys_manager.F | 6 ++++-- src/core_atmosphere/physics/mpas_atmphys_vars.F | 6 ++++-- 3 files changed, 20 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 2e7e947a0..34ad83e77 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -81,6 +81,10 @@ module mpas_atmphys_driver_lsm ! Laura D. Fowler (laura@ucar.edu) / 2016-05-11. ! * added the calculation of surface variables over seaice cells when config_frac_seaice is set to true. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-03. +! * since we removed the local variable lsm_scheme from mpas_atmphys_vars.F, now defines lsm_scheme as a +! pointer to config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. + ! ! DOCUMENTATION: @@ -684,8 +688,13 @@ subroutine init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: sfc_input +!local pointers: + character(len=StrKIND),pointer:: lsm_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_lsm_scheme',lsm_scheme) + lsm_select: select case (trim(lsm_scheme)) case ("noah") @@ -714,13 +723,15 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !local pointers: logical,pointer:: config_sfc_albedo + character(len=StrKIND),pointer:: lsm_scheme character(len=StrKIND),pointer:: mminlu !----------------------------------------------------------------------------------------------------------------- !write(0,*) !write(0,*) '--- enter subroutine driver_lsm:' - call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) + call mpas_pool_get_config(configs,'config_sfc_albedo',config_sfc_albedo) + call mpas_pool_get_config(configs,'config_sfc_albedo',lsm_scheme) call mpas_pool_get_array(sfc_input,'mminlu',mminlu) !formats: @@ -729,7 +740,6 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !copy MPAS arrays to local arrays: call lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) -! write(0,*) '--- end lsm_from_MPAS' !call to land-surface scheme: lsm_select: select case (trim(lsm_scheme)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index a817e1ca3..b5301b144 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -99,7 +99,10 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2016-07-07. ! * in subroutine physics_run_init, removed the initialization of the local variable gwdo_scheme. gwdo_scheme ! is no longer needed and can be replaced with config_gwdo_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2016-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable lsm_scheme. lsm_scheme +! is no longer needed and can be replaced with config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. contains @@ -663,7 +666,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) num_soils = nSoilLevels convection_scheme = trim(config_convection_scheme) - lsm_scheme = trim(config_lsm_scheme) microp_scheme = trim(config_microp_scheme) pbl_scheme = trim(config_pbl_scheme) radt_cld_scheme = trim(config_radt_cld_scheme) diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 9cec70258..d683aaba4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -70,7 +70,10 @@ module mpas_atmphys_vars ! Laura D. Fowler (laura@ucar.edu) / 20016-10-27. ! * removed the initialization local variable gwdo_scheme. gwdo_scheme is no longer needed and can be replaced ! with config_gwdo_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2016-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable lsm_scheme. lsm_scheme is no longer needed and can be replaced +! with config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -79,7 +82,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: microp_scheme character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: lsm_scheme character(len=StrKIND),public:: pbl_scheme character(len=StrKIND),public:: radt_cld_scheme character(len=StrKIND),public:: radt_lw_scheme From 9d657ae1a7aebbd91ba595b5a241360e273f867a Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 10:28:33 -0700 Subject: [PATCH 12/28] * In ./src/core_atmosphere/physics, removed the local variable sfclayer_scheme originally defined in mpas_atmphys_vars.F. sfclayer_scheme is no longer needed and can be replaced with config_sfclayer_scheme. --- .../physics/mpas_atmphys_driver.F | 4 +- .../physics/mpas_atmphys_driver_sfclayer.F | 57 +++++++++++++++---- .../physics/mpas_atmphys_init.F | 2 +- .../physics/mpas_atmphys_manager.F | 8 +-- .../physics/mpas_atmphys_vars.F | 4 +- 5 files changed, 55 insertions(+), 20 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 5ebdaeb28..ed2909baf 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -255,14 +255,14 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to surface-layer scheme: if(config_sfclayer_scheme .ne. 'off') then - call allocate_sfclayer(config_frac_seaice) + call allocate_sfclayer(block%configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_sfclayer(config_frac_seaice) + call deallocate_sfclayer(block%configs) endif !call to 1d ocean mixed-layer model diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index e245a8e1a..0e286cbfe 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -75,17 +75,30 @@ module mpas_atmphys_driver_sfclayer ! * changed the definition of dx_p to match that used in other physics parameterizations. ! parameterizations. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. +! * since we removed the local variable sfclayer_scheme from mpas_atmphys_vars.F, now defines sfclayer_scheme +! as a pointer to config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. + contains !================================================================================================================= - subroutine allocate_sfclayer(config_frac_seaice) + subroutine allocate_sfclayer(configs) !================================================================================================================= - logical,intent(in):: config_frac_seaice +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) if(.not.allocated(cd_p) ) allocate(cd_p(ims:ime,jms:jme) ) @@ -199,12 +212,21 @@ subroutine allocate_sfclayer(config_frac_seaice) end subroutine allocate_sfclayer !================================================================================================================= - subroutine deallocate_sfclayer(config_frac_seaice) + subroutine deallocate_sfclayer(configs) !================================================================================================================= - logical,intent(in):: config_frac_seaice +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + if(allocated(dx_p) ) deallocate(dx_p ) if(allocated(br_p) ) deallocate(br_p ) if(allocated(cd_p) ) deallocate(cd_p ) @@ -323,6 +345,7 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !local pointers: logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),pointer:: len_disp real(kind=RKIND),dimension(:),pointer:: meshDensity @@ -342,8 +365,9 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !----------------------------------------------------------------------------------------------------------------- !input variables: - call mpas_pool_get_config(configs,'config_len_disp' ,len_disp) - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + call mpas_pool_get_config(configs,'config_len_disp' ,len_disp ) call mpas_pool_get_array(mesh,'meshDensity',meshDensity) call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) @@ -567,6 +591,7 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) !local pointers: logical,pointer:: config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: br,cpm,chs,chs2,cqs2,flhc,flqc,gz1oz0,hfx,qfx, & qgh,qsfc,lh,mol,psim,psih,regime,rmol,ust,wspd, & @@ -584,7 +609,8 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) !inout variables: call mpas_pool_get_array(diag_physics,'br' ,br ) @@ -754,14 +780,20 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) end subroutine sfclayer_to_MPAS !================================================================================================================= - subroutine init_sfclayer + subroutine init_sfclayer(configs) !================================================================================================================= -!local variables: +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local variables and pointers: logical, parameter:: allowed_to_read = .false. !actually not used in subroutine sfclayinit. + character(len=StrKIND),pointer:: sfclayer_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme) + sfclayer_select: select case (trim(sfclayer_scheme)) case("sf_monin_obukhov") @@ -774,7 +806,6 @@ subroutine init_sfclayer end select sfclayer_select - end subroutine init_sfclayer !================================================================================================================= @@ -794,6 +825,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite !local pointers: logical,pointer:: config_do_restart,config_frac_seaice + character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: areaCell !local variables: @@ -804,8 +836,9 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite !write(0,*) !write(0,*) '--- enter subroutine driver_sfclayer:' - call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) call mpas_pool_get_array(mesh,'areaCell',areaCell) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 26931649a..d5aa079f2 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -357,7 +357,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ call microphysics_init(dminfo,mesh,sfc_input,diag_physics) !initialization of surface layer processes: - if(config_sfclayer_scheme .ne. 'off') call init_sfclayer + if(config_sfclayer_scheme .ne. 'off') call init_sfclayer(configs) !initialization of land-surface model: !if(.not. config_do_restart) then diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index b5301b144..3775d3b3c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -102,6 +102,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable lsm_scheme. lsm_scheme ! is no longer needed and can be replaced with config_lsm_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable sfclayer_scheme. +! sfclayer_scheme is no longer needed and can be replaced with config_sfclayer_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -368,8 +371,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) config_pbl_scheme, & config_radt_cld_scheme, & config_radt_lw_scheme, & - config_radt_sw_scheme, & - config_sfclayer_scheme + config_radt_sw_scheme character(len=StrKIND),pointer:: config_conv_interval, & config_pbl_interval, & @@ -408,7 +410,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_config(configs,'config_radt_cld_scheme' ,config_radt_cld_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) - call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) call mpas_pool_get_config(configs,'config_conv_interval' ,config_conv_interval ) call mpas_pool_get_config(configs,'config_pbl_interval' ,config_pbl_interval ) @@ -671,7 +672,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) radt_cld_scheme = trim(config_radt_cld_scheme) radt_lw_scheme = trim(config_radt_lw_scheme) radt_sw_scheme = trim(config_radt_sw_scheme) - sfclayer_scheme = trim(config_sfclayer_scheme) if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index d683aaba4..1517716fd 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -74,6 +74,9 @@ module mpas_atmphys_vars ! * removed the initialization local variable lsm_scheme. lsm_scheme is no longer needed and can be replaced ! with config_lsm_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable sfclayer_scheme. sfclayer_scheme is no longer needed and can be +! replaced with config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -86,7 +89,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: radt_cld_scheme character(len=StrKIND),public:: radt_lw_scheme character(len=StrKIND),public:: radt_sw_scheme - character(len=StrKIND),public:: sfclayer_scheme !================================================================================================================= !wrf-variables:these variables are needed to keep calls to different physics parameterizations From ba9c895b4e26a9c2445bfc143c448821e42ece93 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 11:09:45 -0700 Subject: [PATCH 13/28] * In ./src/core_atmosphere/physics, removed the local variable pbl_scheme originally defined in mpas_atmphys_vars.F. pbl_scheme is no longer needed and can be replaced with config_pbl_scheme. --- .../physics/mpas_atmphys_driver.F | 10 ++--- .../physics/mpas_atmphys_driver_pbl.F | 45 +++++++++++++++++-- .../physics/mpas_atmphys_interface.F | 31 +++++++++++-- .../physics/mpas_atmphys_manager.F | 6 +-- .../physics/mpas_atmphys_todynamics.F | 6 +-- .../physics/mpas_atmphys_vars.F | 4 +- 6 files changed, 83 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index ed2909baf..cd92d535a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -188,14 +188,14 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) !allocate arrays shared by all physics parameterizations: - call allocate_forall_physics + call allocate_forall_physics(configs) !physics prep step: time_lev = 1 !$OMP PARALLEL DO do thread=1,nThreads - call MPAS_to_physics(mesh,state,time_lev,diag,diag_physics, & + call MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO @@ -282,14 +282,14 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to pbl schemes: if(config_pbl_scheme .ne. 'off' .and. config_sfclayer_scheme .ne. 'off') then - call allocate_pbl + call allocate_pbl(configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_pbl(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_pbl + call deallocate_pbl(configs) endif !call to gravity wave drag over orography scheme: @@ -332,7 +332,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) end if !deallocate arrays shared by all physics parameterizations: - call deallocate_forall_physics + call deallocate_forall_physics(configs) block => block % next end do diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 4f8f39f6c..6136eecd1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -62,15 +62,28 @@ module mpas_atmphys_driver_pbl ! * updated the call to subroutine ysu in comjunction with updating module_bl_ysu.F from WRF version 3.6.1 to ! WRF version 3.8.1 ! Laura D. Fowler (laura@ucar.edu) / 2016-10-27. +! * since we removed the local variable pbl_scheme from mpas_atmphys_vars.F, now defines pbl_scheme as a pointer +! to config_pbl_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_pbl + subroutine allocate_pbl(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(.not.allocated(hfx_p) ) allocate(hfx_p(ims:ime,jms:jme) ) if(.not.allocated(qfx_p) ) allocate(qfx_p(ims:ime,jms:jme) ) if(.not.allocated(ust_p) ) allocate(ust_p(ims:ime,jms:jme) ) @@ -147,9 +160,19 @@ subroutine allocate_pbl end subroutine allocate_pbl !================================================================================================================= - subroutine deallocate_pbl + subroutine deallocate_pbl(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(allocated(hfx_p) ) deallocate(hfx_p ) if(allocated(qfx_p) ) deallocate(qfx_p ) if(allocated(ust_p) ) deallocate(ust_p ) @@ -240,6 +263,8 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it integer:: i,k,j !local pointers: + character(len=StrKIND),pointer:: pbl_scheme + real(kind=RKIND),dimension(:),pointer:: hfx,hpbl,qfx,ust,wspd,xland,znt real(kind=RKIND),dimension(:),pointer:: delta,wstar @@ -256,6 +281,8 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) @@ -407,9 +434,12 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it end subroutine pbl_from_MPAS !================================================================================================================= - subroutine pbl_to_MPAS(diag_physics,tend_physics,its,ite) + subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend_physics @@ -420,7 +450,10 @@ subroutine pbl_to_MPAS(diag_physics,tend_physics,its,ite) integer:: i,k,j !local pointers: + character(len=StrKIND),pointer:: pbl_scheme + integer,dimension(:),pointer:: kpbl + real(kind=RKIND),dimension(:),pointer :: hpbl real(kind=RKIND),dimension(:,:),pointer:: kzh,kzm,kzq real(kind=RKIND),dimension(:,:),pointer:: rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten, & @@ -436,6 +469,8 @@ subroutine pbl_to_MPAS(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_array(diag_physics,'kpbl' ,kpbl ) call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) call mpas_pool_get_array(diag_physics,'kzh' ,kzh ) @@ -553,6 +588,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics !local pointers: logical,pointer:: config_do_restart + character(len=StrKIND),pointer:: pbl_scheme !local variables: integer:: initflag @@ -563,6 +599,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics !write(0,*) '--- enter subroutine driver_pbl:' call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme ) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -635,7 +672,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics end select pbl_select !copy local arrays to MPAS grid: - call pbl_to_MPAS(diag_physics,tend_physics,its,ite) + call pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) !write(0,*) '--- end subroutine driver_pbl.' diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 92da27b0b..d1cf9fd73 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -70,9 +70,19 @@ module mpas_atmphys_interface !================================================================================================================= - subroutine allocate_forall_physics + subroutine allocate_forall_physics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(.not.allocated(psfc_p) ) allocate(psfc_p(ims:ime,jms:jme) ) if(.not.allocated(ptop_p) ) allocate(ptop_p(ims:ime,jms:jme) ) @@ -124,9 +134,19 @@ subroutine allocate_forall_physics end subroutine allocate_forall_physics !================================================================================================================= - subroutine deallocate_forall_physics + subroutine deallocate_forall_physics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: pbl_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + if(allocated(psfc_p) ) deallocate(psfc_p ) if(allocated(ptop_p) ) deallocate(ptop_p ) @@ -177,10 +197,11 @@ subroutine deallocate_forall_physics end subroutine deallocate_forall_physics !================================================================================================================= - subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) + subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: diag @@ -192,6 +213,8 @@ subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: pbl_scheme + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg integer,pointer:: index_ni @@ -223,6 +246,8 @@ subroutine MPAS_to_physics(mesh,state,time_lev,diag,diag_physics,its,ite) !write(0,*) 'kts=',kts,' kte=',kte !initialization: + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) call mpas_pool_get_array(mesh,'fzm' ,fzm ) diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 3775d3b3c..20e12dadd 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -105,6 +105,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable sfclayer_scheme. ! sfclayer_scheme is no longer needed and can be replaced with config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable pbl_scheme. pbl_scheme +! is no longer needed and can be replaced with config_pbl_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -368,7 +371,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) character(len=StrKIND),pointer:: config_convection_scheme, & config_lsm_scheme, & config_microp_scheme, & - config_pbl_scheme, & config_radt_cld_scheme, & config_radt_lw_scheme, & config_radt_sw_scheme @@ -406,7 +408,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) - call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) call mpas_pool_get_config(configs,'config_radt_cld_scheme' ,config_radt_cld_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) @@ -668,7 +669,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) convection_scheme = trim(config_convection_scheme) microp_scheme = trim(config_microp_scheme) - pbl_scheme = trim(config_pbl_scheme) radt_cld_scheme = trim(config_radt_cld_scheme) radt_lw_scheme = trim(config_radt_lw_scheme) radt_sw_scheme = trim(config_radt_sw_scheme) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index a7ce596be..365325384 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -12,7 +12,7 @@ module mpas_atmphys_todynamics use mpas_dmpar use mpas_atmphys_constants, only: R_d,R_v,degrad - use mpas_atmphys_vars, only: pbl_scheme,convection_scheme + use mpas_atmphys_vars, only: convection_scheme implicit none private @@ -529,7 +529,7 @@ subroutine physics_addtend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdges enddo enddo - pbl_select: select case (trim(pbl_scheme)) + pbl_select: select case (trim(config_pbl_scheme)) case("bl_mynn") @@ -713,7 +713,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge enddo enddo - pbl_select: select case (trim(pbl_scheme)) + pbl_select: select case (trim(config_pbl_scheme)) case("bl_mynn") diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 1517716fd..cc6a91b17 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -77,6 +77,9 @@ module mpas_atmphys_vars ! * removed the initialization local variable sfclayer_scheme. sfclayer_scheme is no longer needed and can be ! replaced with config_sfclayer_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable pbl_scheme. pbl_scheme is no longer needed and can be replaced +! replaced with config_pbl_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -85,7 +88,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: microp_scheme character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: pbl_scheme character(len=StrKIND),public:: radt_cld_scheme character(len=StrKIND),public:: radt_lw_scheme character(len=StrKIND),public:: radt_sw_scheme From 81415a18520652d89928298606f4d38ad76ad5f2 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 12:18:43 -0700 Subject: [PATCH 14/28] * In ./src/core_atmosphere/physics, made a few corrections to mpas_atmphys_driver.F and mpas_atmphys_driver_lsm.F. Results are identical as the ones obtained when using reference f6b4ae3badf7d531b0f9. --- src/core_atmosphere/physics/mpas_atmphys_driver.F | 11 ++++++----- src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F | 2 +- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index cd92d535a..f4912ed7e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -188,14 +188,14 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) !allocate arrays shared by all physics parameterizations: - call allocate_forall_physics(configs) + call allocate_forall_physics(block%configs) !physics prep step: time_lev = 1 !$OMP PARALLEL DO do thread=1,nThreads - call MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics, & + call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO @@ -282,14 +282,15 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to pbl schemes: if(config_pbl_scheme .ne. 'off' .and. config_sfclayer_scheme .ne. 'off') then - call allocate_pbl(configs) + call allocate_pbl(block%configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_pbl(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_pbl(configs) + call deallocate_pbl(block%configs) + endif !call to gravity wave drag over orography scheme: @@ -332,7 +333,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) end if !deallocate arrays shared by all physics parameterizations: - call deallocate_forall_physics(configs) + call deallocate_forall_physics(block%configs) block => block % next end do diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 34ad83e77..34a4408de 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -731,7 +731,7 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !write(0,*) '--- enter subroutine driver_lsm:' call mpas_pool_get_config(configs,'config_sfc_albedo',config_sfc_albedo) - call mpas_pool_get_config(configs,'config_sfc_albedo',lsm_scheme) + call mpas_pool_get_config(configs,'config_lsm_scheme',lsm_scheme) call mpas_pool_get_array(sfc_input,'mminlu',mminlu) !formats: From 9df53f3cad8928b8075f342569a6cf3d9fbe0e7b Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 12:13:24 -0700 Subject: [PATCH 15/28] * In ./src/core_atmosphere/physics, removed the local variable radt_cld_scheme originally defined in mpas_atmphys_vars.F. radt_cld_scheme is no longer needed and can be replaced with config_radt_cld_scheme. --- .../physics/mpas_atmphys_driver_cloudiness.F | 9 ++++++++- src/core_atmosphere/physics/mpas_atmphys_manager.F | 6 +++--- src/core_atmosphere/physics/mpas_atmphys_vars.F | 4 +++- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F index 54825d699..0c953fcb0 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F @@ -48,6 +48,9 @@ module mpas_atmphys_driver_cloudiness ! cloud formation, but changes to the cloud water and cloud ice mixing ratios only affect the long wave and ! short wave radiation codes. ! Laura D. Fowler (laura@ucar.edu) / 2016-07-05. +! * since we removed the local variable radt_cld_scheme from mpas_atmphys_vars.F, now defines radt_cld_scheme +! as a pointer to config_radt_cld_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains @@ -176,13 +179,17 @@ subroutine driver_cloudiness(configs,mesh,diag_physics,sfc_input,its,ite) !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics -!local variables: +!local variables and pointers: + character(len=StrKIND),pointer:: radt_cld_scheme + integer:: i,j,k !----------------------------------------------------------------------------------------------------------------- !write(0,*) !write(0,*) '--- enter subroutine driver_cloudiness:' + call mpas_pool_get_config(configs,'config_radt_cld_scheme',radt_cld_scheme) + !copy MPAS arrays to local arrays: call cloudiness_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 20e12dadd..f39a286c4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -108,6 +108,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable pbl_scheme. pbl_scheme ! is no longer needed and can be replaced with config_pbl_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable radt_cld_scheme. +! radt_cld_scheme is no longer needed and can be replaced with config_radt_cld_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -371,7 +374,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) character(len=StrKIND),pointer:: config_convection_scheme, & config_lsm_scheme, & config_microp_scheme, & - config_radt_cld_scheme, & config_radt_lw_scheme, & config_radt_sw_scheme @@ -408,7 +410,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) - call mpas_pool_get_config(configs,'config_radt_cld_scheme' ,config_radt_cld_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) @@ -669,7 +670,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) convection_scheme = trim(config_convection_scheme) microp_scheme = trim(config_microp_scheme) - radt_cld_scheme = trim(config_radt_cld_scheme) radt_lw_scheme = trim(config_radt_lw_scheme) radt_sw_scheme = trim(config_radt_sw_scheme) diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index cc6a91b17..015b28443 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -80,6 +80,9 @@ module mpas_atmphys_vars ! * removed the initialization local variable pbl_scheme. pbl_scheme is no longer needed and can be replaced ! replaced with config_pbl_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable radt_cld_scheme. radt_cld_scheme is no longer needed and can be +! replaced replaced with config_radt_cld_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -88,7 +91,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: microp_scheme character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: radt_cld_scheme character(len=StrKIND),public:: radt_lw_scheme character(len=StrKIND),public:: radt_sw_scheme From 46e7f21012edbb63fc3e3938d3486eb8b55830eb Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 12:58:29 -0700 Subject: [PATCH 16/28] * In ./src/core_atmosphere/physics, removed the local variable radt_lw_scheme originally defined in mpas_atmphys_vars.F. radt_lw_scheme is no longer needed and can be replaced with config_radt_lw_scheme. --- .../physics/mpas_atmphys_driver.F | 4 +- .../mpas_atmphys_driver_radiation_lw.F | 50 ++++++++++++++++--- .../physics/mpas_atmphys_init.F | 4 +- .../physics/mpas_atmphys_manager.F | 6 ++- .../physics/mpas_atmphys_vars.F | 4 +- 5 files changed, 54 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index f4912ed7e..b3623a3c9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -227,7 +227,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to long wave radiation scheme: if(l_radtlw) then time_lev = 1 - call allocate_radiation_lw(xtime_s) + call allocate_radiation_lw(block%configs,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_radiation_lw(xtime_s,block%configs,mesh,state,time_lev,diag_physics, & @@ -251,7 +251,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') & call deallocate_cloudiness if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw - if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw + if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw(block%configs) !call to surface-layer scheme: if(config_sfclayer_scheme .ne. 'off') then diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 9d2159bcf..1a81efebe 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -84,20 +84,29 @@ module mpas_atmphys_driver_radiation_lw ! * substituted "use mpas_atmphys_o3climatology" with "use module_ra_rrtmg_vinterp" since we moved subroutine ! vinterp_ozn to is own module in physics_wrf. ! laura D. Fowler (laura@ucar.edu) / 2017-01-27. +! * since we removed the local variable radt_lw_scheme from mpas_atmphys_vars.F, now defines radt_lw_scheme +! as a pointer to config_radt_lw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_radiation_lw(xtime_s) + subroutine allocate_radiation_lw(configs,xtime_s) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs real(kind=RKIND),intent(in):: xtime_s +!local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) ) @@ -192,9 +201,19 @@ subroutine allocate_radiation_lw(xtime_s) end subroutine allocate_radiation_lw !================================================================================================================= - subroutine deallocate_radiation_lw + subroutine deallocate_radiation_lw(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + if(allocated(f_ice) ) deallocate(f_ice ) if(allocated(f_rain) ) deallocate(f_rain ) if(allocated(sfc_emiss_p) ) deallocate(sfc_emiss_p ) @@ -294,6 +313,7 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_lw_scheme real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland @@ -310,7 +330,8 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -561,16 +582,21 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi end subroutine radiation_lw_from_MPAS !================================================================================================================= - subroutine radiation_lw_to_MPAS(diag_physics,tend_physics,its,ite) + subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs + +!inout arguments: type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend_physics integer,intent(in):: its,ite !local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + real(kind=RKIND),dimension(:),pointer :: glw,lwcf,lwdnb,lwdnbc,lwdnt,lwdntc,lwupb,lwupbc, & lwupt,lwuptc,olrtoa real(kind=RKIND),dimension(:,:),pointer:: rthratenlw @@ -583,6 +609,8 @@ subroutine radiation_lw_to_MPAS(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) call mpas_pool_get_array(diag_physics,'lwcf' ,lwcf ) call mpas_pool_get_array(diag_physics,'lwdnb' ,lwdnb ) @@ -690,11 +718,12 @@ subroutine radiation_camlw_to_MPAS(diag_physics,its,ite) end subroutine radiation_camlw_to_MPAS !================================================================================================================= - subroutine init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) + subroutine init_radiation_lw(dminfo,configs,mesh,atm_input,diag,state,time_lev) !================================================================================================================= !input arguments: type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in),optional:: mesh type(mpas_pool_type),intent(in),optional:: diag @@ -704,8 +733,13 @@ subroutine init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) type(mpas_pool_type),intent(inout),optional:: atm_input type(mpas_pool_type),intent(inout),optional:: state +!local pointers: + character(len=StrKIND),pointer:: radt_lw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) + radiation_lw_select: select case (trim(radt_lw_scheme)) case ("rrtmg_lw") @@ -742,6 +776,7 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_lw_scheme !local variables: integer:: o3input @@ -754,7 +789,8 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, 100 format(/,' --- enter subroutine driver_radiation_lw: ',i6) 101 format(i8,12(1x,e15.8)) - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) !copy MPAS arrays to local arrays: call radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physics,atm_input,sfc_input,its,ite) @@ -851,7 +887,7 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, end select radiation_lw_select !copy local arrays to MPAS grid: - call radiation_lw_to_MPAS(diag_physics,tend_physics,its,ite) + call radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !write(0,*) '--- end subroutine driver_radiation_lw.' diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index d5aa079f2..8366e2598 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -382,13 +382,13 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ if(config_radt_lw_scheme.ne.'off') then if(trim(config_radt_lw_scheme) .eq. 'cam_lw') then if(.not. init_done) then - call init_radiation_lw(dminfo,mesh,atm_input,diag,state,time_lev) + call init_radiation_lw(dminfo,configs,mesh,atm_input,diag,state,time_lev) else ! write(0,*) ! write(0,*) '--- camrad lw initialization done above' endif else - call init_radiation_lw(dminfo) + call init_radiation_lw(dminfo,configs) endif endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index f39a286c4..bf355cad7 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -111,6 +111,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable radt_cld_scheme. ! radt_cld_scheme is no longer needed and can be replaced with config_radt_cld_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable radt_lw_scheme. +! radt_lw_scheme is no longer needed and can be replaced with config_radt_lw_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -670,7 +673,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) convection_scheme = trim(config_convection_scheme) microp_scheme = trim(config_microp_scheme) - radt_lw_scheme = trim(config_radt_lw_scheme) radt_sw_scheme = trim(config_radt_sw_scheme) if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 @@ -744,7 +746,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) if(config_microp_re) then if(trim(microp_scheme)=='mp_thompson' .or. & trim(microp_scheme)=='mp_wsm6') then - if(trim(radt_lw_scheme)=='rrtmg_lw' .and. trim(radt_sw_scheme)=='rrtmg_sw') then + if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(radt_sw_scheme)=='rrtmg_sw') then has_reqc = 1 has_reqi = 1 has_reqs = 1 diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 015b28443..4dcb2b985 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -83,6 +83,9 @@ module mpas_atmphys_vars ! * removed the initialization local variable radt_cld_scheme. radt_cld_scheme is no longer needed and can be ! replaced replaced with config_radt_cld_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable radt_lw_scheme. radt_lw_scheme is no longer needed and can be +! replaced replaced with config_radt_lw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -91,7 +94,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: microp_scheme character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: radt_lw_scheme character(len=StrKIND),public:: radt_sw_scheme !================================================================================================================= From b485b31f34500859be522b66bfc3b13ec0fb64de Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 13:36:59 -0700 Subject: [PATCH 17/28] * In ./src/core_atmosphere/physics, removed the local variable radt_sw_scheme originally defined in mpas_atmphys_vars.F. radt_sw_scheme is no longer needed and can be replaced with config_radt_sw_scheme. --- .../physics/mpas_atmphys_driver.F | 4 +- .../mpas_atmphys_driver_radiation_sw.F | 39 ++++++++++++++++--- .../physics/mpas_atmphys_init.F | 4 +- .../physics/mpas_atmphys_manager.F | 6 ++- .../physics/mpas_atmphys_vars.F | 4 +- 5 files changed, 45 insertions(+), 12 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index b3623a3c9..735bc9412 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -214,7 +214,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to short wave radiation scheme: if(l_radtsw) then time_lev = 1 - call allocate_radiation_sw(xtime_s) + call allocate_radiation_sw(block%configs,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_radiation_sw(itimestep,block%configs,mesh,state,time_lev,diag_physics, & @@ -250,7 +250,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !deallocate all radiation arrays: if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') & call deallocate_cloudiness - if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw + if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw(block%configs) if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw(block%configs) !call to surface-layer scheme: diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index 143ba5933..b9d7cd7e0 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -76,20 +76,29 @@ module mpas_atmphys_driver_radiation_sw ! * in the call to rrtmg_swrad, substituted the variables qv_p, qc_p, qi_p, and qs_p with qvrad_p, qcrad_p, ! qirad_p, and qsrad_p initialized in subroutine cloudiness_from_MPAS. ! Laura D. Fowler (laura@ucar.edu) / 2016-07-09. +! * since we removed the local variable radt_sw_scheme from mpas_atmphys_vars.F, now defines radt_sw_scheme +! as a pointer to config_radt_sw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_radiation_sw(xtime_s) + subroutine allocate_radiation_sw(configs,xtime_s) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs real(kind=RKIND),intent(in):: xtime_s +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) ) @@ -189,9 +198,19 @@ subroutine allocate_radiation_sw(xtime_s) end subroutine allocate_radiation_sw !================================================================================================================= - subroutine deallocate_radiation_sw + subroutine deallocate_radiation_sw(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + if(allocated(f_ice) ) deallocate(f_ice ) if(allocated(f_rain) ) deallocate(f_rain ) if(allocated(xlat_p) ) deallocate(xlat_p ) @@ -295,6 +314,7 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_sw_scheme real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland @@ -306,7 +326,8 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -601,11 +622,12 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) end subroutine radiation_sw_to_MPAS !================================================================================================================= - subroutine init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) + subroutine init_radiation_sw(dminfo,configs,mesh,atm_input,diag,state,time_lev) !================================================================================================================= !input arguments: type(dm_info), intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in),optional:: mesh type(mpas_pool_type),intent(in),optional:: diag @@ -615,8 +637,13 @@ subroutine init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) type(mpas_pool_type),intent(inout),optional:: atm_input type(mpas_pool_type),intent(inout),optional:: state +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -657,6 +684,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !local pointers: logical,pointer:: config_o3climatology + character(len=StrKIND),pointer:: radt_sw_scheme !local variables: integer:: o3input @@ -665,7 +693,8 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !----------------------------------------------------------------------------------------------------------------- !write(0,100) itimestep - call mpas_pool_get_config(configs,'config_o3climatology',config_o3climatology) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme ) !formats: 100 format(/,' --- enter subroutine driver_radiation_sw: ',i6) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 8366e2598..e9d1e9cde 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -369,10 +369,10 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ init_done = .false. if(config_radt_sw_scheme.ne.'off') then if(trim(config_radt_sw_scheme) .eq. 'cam_sw') then - call init_radiation_sw(dminfo,mesh,atm_input,diag,state,time_lev) + call init_radiation_sw(dminfo,configs,mesh,atm_input,diag,state,time_lev) init_done = .true. else - call init_radiation_sw(dminfo) + call init_radiation_sw(dminfo,configs) endif endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index bf355cad7..774f6e8af 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -114,6 +114,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable radt_lw_scheme. ! radt_lw_scheme is no longer needed and can be replaced with config_radt_lw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable radt_sw_scheme. +! radt_sw_scheme is no longer needed and can be replaced with config_radt_sw_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -673,7 +676,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) convection_scheme = trim(config_convection_scheme) microp_scheme = trim(config_microp_scheme) - radt_sw_scheme = trim(config_radt_sw_scheme) if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 @@ -746,7 +748,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) if(config_microp_re) then if(trim(microp_scheme)=='mp_thompson' .or. & trim(microp_scheme)=='mp_wsm6') then - if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(radt_sw_scheme)=='rrtmg_sw') then + if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(config_radt_sw_scheme)=='rrtmg_sw') then has_reqc = 1 has_reqi = 1 has_reqs = 1 diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 4dcb2b985..a90a73ebf 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -86,6 +86,9 @@ module mpas_atmphys_vars ! * removed the initialization local variable radt_lw_scheme. radt_lw_scheme is no longer needed and can be ! replaced replaced with config_radt_lw_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable radt_sw_scheme. radt_sw_scheme is no longer needed and can be +! replaced replaced with config_radt_sw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -94,7 +97,6 @@ module mpas_atmphys_vars character(len=StrKIND),public:: microp_scheme character(len=StrKIND),public:: convection_scheme - character(len=StrKIND),public:: radt_sw_scheme !================================================================================================================= !wrf-variables:these variables are needed to keep calls to different physics parameterizations From 068ac967cc41e656f6c19a7a8758ee51d7c80530 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 14 Feb 2017 19:15:18 -0700 Subject: [PATCH 18/28] Modify Makefiles in core_atmosphere to enable parallel builds This commit makes several modifications to Makefiles within the core_atmosphere directory to enable parallel builds of MPAS-Atmosphere. --- src/core_atmosphere/Makefile | 4 ++-- src/core_atmosphere/physics/Makefile | 10 +++++++--- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index ca73840fc..2e77cf884 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -34,7 +34,7 @@ physcore: mpas_atm_dimensions.o ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*TBL .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) -dycore: mpas_atm_dimensions.o +dycore: mpas_atm_dimensions.o physcore ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) diagcore: physcore dycore @@ -48,7 +48,7 @@ atmcore: physcore dycore diagcore $(OBJS) mpas_atm_core_interface.o: mpas_atm_core.o -mpas_atm_core.o: dycore mpas_atm_threading.o +mpas_atm_core.o: dycore diagcore mpas_atm_threading.o mpas_atm_dimensions.o: diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index dcaf41f95..e8cb03f6f 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -49,14 +49,17 @@ lookup_tables: ./checkout_data_files.sh core_physics_wrf: - (cd physics_wrf; make all COREDEF="$(COREDEF)") + (cd physics_wrf; $(MAKE) all COREDEF="$(COREDEF)") core_physics_init: $(OBJS_init) ar -ru libphys.a $(OBJS_init) -core_physics: $(OBJS) +core_physics: core_physics_wrf + ($(MAKE) phys_interface COREDEF="$(COREDEF)") ar -ru libphys.a $(OBJS) +phys_interface: $(OBJS) + # DEPENDENCIES: mpas_atmphys_camrad_init.o: \ mpas_atmphys_constants.o \ @@ -107,6 +110,7 @@ mpas_atmphys_driver_microphysics.o: \ mpas_atmphys_driver_oml.o: \ mpas_atmphys_constants.o \ + mpas_atmphys_landuse.o \ mpas_atmphys_vars.o mpas_atmphys_driver_pbl.o: \ @@ -190,7 +194,7 @@ mpas_atmphys_update.o: \ clean: $(RM) *.o *.mod *.f90 libphys.a - ( cd physics_wrf; make clean ) + ( cd physics_wrf; $(MAKE) clean ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i From 5b95c7f38ec851a2dcb763f45659e6f88fafae99 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 14:07:40 -0700 Subject: [PATCH 19/28] * In ./src/core_atmosphere/physics, removed the local variable convection_scheme originally defined in mpas_atmphys_vars.F. convection_scheme is no longer needed and can be replaced with config_convection_scheme. --- .../physics/mpas_atmphys_driver.F | 6 +-- .../physics/mpas_atmphys_driver_convection.F | 54 +++++++++++++++---- .../physics/mpas_atmphys_manager.F | 4 +- .../physics/mpas_atmphys_todynamics.F | 5 +- .../physics/mpas_atmphys_vars.F | 4 +- 5 files changed, 56 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 735bc9412..6ca915070 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -308,19 +308,19 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to convection scheme: !$OMP PARALLEL DO do thread=1,nThreads - call update_convection_step1(diag_physics,tend_physics, & + call update_convection_step1(block%configs,diag_physics,tend_physics, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO if(l_conv) then - call allocate_convection + call allocate_convection(block%configs) !$OMP PARALLEL DO do thread=1,nThreads call driver_convection(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_convection + call deallocate_convection(block%configs) endif !update diagnostics: if(config_convection_scheme .ne. 'off') then diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index 0146e350b..e4c4ff79f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -87,20 +87,30 @@ module mpas_atmphys_driver_convection ! * for the kain_fritsch parameterization of convection, change the definition of dx_p to match that used in the ! Grell-Freitas and "new Tiedtke" parameterization. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. +! * since we removed the local variable convection_scheme from mpas_atmphys_vars.F, now defines convection_scheme +! as a pointer to config_convection_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. contains !================================================================================================================= - subroutine allocate_convection + subroutine allocate_convection(configs) !================================================================================================================= -!local variables: +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local variables and pointers: + character(len=StrKIND),pointer:: convection_scheme + integer:: i,k,j !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + if(.not.allocated(cu_act_flag)) allocate(cu_act_flag(ims:ime,jms:jme) ) if(.not.allocated(rthcuten_p) ) allocate(rthcuten_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(rqvcuten_p) ) allocate(rqvcuten_p(ims:ime,kms:kme,jms:jme)) @@ -251,9 +261,19 @@ subroutine allocate_convection end subroutine allocate_convection !================================================================================================================= - subroutine deallocate_convection + subroutine deallocate_convection(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: convection_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + if(allocated(cu_act_flag)) deallocate(cu_act_flag) if(allocated(rthcuten_p) ) deallocate(rthcuten_p ) if(allocated(rqvcuten_p) ) deallocate(rqvcuten_p ) @@ -346,6 +366,8 @@ subroutine init_convection(mesh,configs,diag_physics) !local pointers: logical,pointer:: config_do_restart + character(len=StrKIND),pointer:: convection_scheme + integer,pointer:: nCells real(kind=RKIND),dimension(:),pointer:: nca @@ -355,7 +377,8 @@ subroutine init_convection(mesh,configs,diag_physics) !----------------------------------------------------------------------------------------------------------------- call mpas_pool_get_dimension(mesh,'nCells',nCells) - call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart) + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) convection_select: select case(convection_scheme) @@ -401,6 +424,7 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ !local pointers: logical,pointer:: config_do_restart integer,pointer:: gfconv_closure_deep,gfconv_closure_shallow + character(len=StrKIND),pointer:: convection_scheme real(kind=RKIND),pointer:: len_disp !variables specific to Kain_Fritsch parameterization: @@ -416,8 +440,9 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ call mpas_pool_get_config(configs,'config_gfconv_closure_deep',gfconv_closure_deep) call mpas_pool_get_config(configs,'config_gfconv_closure_shallow',gfconv_closure_shallow) - call mpas_pool_get_config(configs,'config_len_disp',len_disp) - call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + call mpas_pool_get_config(configs,'config_len_disp' ,len_disp ) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart) + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) !initialize instantaneous precipitation, and copy convective tendencies from the dynamics to !the physics grid: @@ -567,7 +592,7 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ !copy instantaneous and accumulated precipitation, convective tendencies, and "other" arrays !specific to convection parameterization back to the dynamics grid: - call convection_to_MPAS(diag_physics,tend_physics,its,ite) + call convection_to_MPAS(configs,diag_physics,tend_physics,its,ite) !write(0,*) '--- end subroutine driver_convection.' !write(0,*) @@ -589,6 +614,7 @@ subroutine convection_from_MPAS(dt_dyn,configs,mesh,sfc_input,diag_physics,tend_ real(kind=RKIND),intent(in):: dt_dyn !local pointers: + character(len=StrKIND),pointer:: convection_scheme integer,dimension(:),pointer:: kpbl,k22_shallow,kbcon_shallow,ktop_shallow,ktop_deep real(kind=RKIND),dimension(:),pointer :: areaCell,meshDensity real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv @@ -608,6 +634,8 @@ subroutine convection_from_MPAS(dt_dyn,configs,mesh,sfc_input,diag_physics,tend_ !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_array(diag_physics,'cuprec',cuprec) call mpas_pool_get_array(diag_physics,'raincv',raincv) @@ -811,10 +839,11 @@ subroutine convection_from_MPAS(dt_dyn,configs,mesh,sfc_input,diag_physics,tend_ end subroutine convection_from_MPAS !================================================================================================================= - subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) + subroutine convection_to_MPAS(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !inout arguments: @@ -825,6 +854,7 @@ subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) integer:: i,k,j !local pointers: + character(len=StrKIND),pointer:: convection_scheme integer,dimension(:),pointer:: k22_shallow,kbcon_shallow,ktop_shallow,ktop_deep real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv real(kind=RKIND),dimension(:),pointer :: xmb_total,xmb_shallow @@ -835,6 +865,8 @@ subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_array(diag_physics,'cuprec',cuprec) call mpas_pool_get_array(diag_physics,'raincv',raincv) @@ -935,10 +967,11 @@ subroutine convection_to_MPAS(diag_physics,tend_physics,its,ite) end subroutine convection_to_MPAS !================================================================================================================= - subroutine update_convection_step1(diag_physics,tend_physics,its,ite) + subroutine update_convection_step1(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !inout arguments: @@ -946,6 +979,7 @@ subroutine update_convection_step1(diag_physics,tend_physics,its,ite) type(mpas_pool_type),intent(inout):: tend_physics !local pointers: + character(len=StrKIND),pointer:: convection_scheme real(kind=RKIND),dimension(:),pointer :: nca,cubot,cutop,cuprec,raincv real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten,rqicuten,rqrcuten,rqscuten @@ -954,6 +988,8 @@ subroutine update_convection_step1(diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + convection_select: select case(convection_scheme) case ("cu_kain_fritsch") diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 774f6e8af..d25be8866 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -117,6 +117,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable radt_sw_scheme. ! radt_sw_scheme is no longer needed and can be replaced with config_radt_sw_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable convection_scheme. +! convection_scheme is no longer needed and can be replaced with config_convection_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -674,7 +677,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) num_months = nMonths num_soils = nSoilLevels - convection_scheme = trim(config_convection_scheme) microp_scheme = trim(config_microp_scheme) if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 365325384..4d0bc9ac9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -12,7 +12,6 @@ module mpas_atmphys_todynamics use mpas_dmpar use mpas_atmphys_constants, only: R_d,R_v,degrad - use mpas_atmphys_vars, only: convection_scheme implicit none private @@ -556,7 +555,7 @@ subroutine physics_addtend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdges enddo enddo - convection_select: select case(convection_scheme) + convection_select: select case(config_convection_scheme) case('cu_grell_freitas') @@ -740,7 +739,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge enddo enddo - convection_select: select case(convection_scheme) + convection_select: select case(config_convection_scheme) case('cu_kain_fritsch') do i = 1, nCellsSolve diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index a90a73ebf..5372bc226 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -89,6 +89,9 @@ module mpas_atmphys_vars ! * removed the initialization local variable radt_sw_scheme. radt_sw_scheme is no longer needed and can be ! replaced replaced with config_radt_sw_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable convection_scheme. convection_scheme is no longer needed and can be +! replaced replaced with config_convection_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. !================================================================================================================= @@ -96,7 +99,6 @@ module mpas_atmphys_vars !================================================================================================================= character(len=StrKIND),public:: microp_scheme - character(len=StrKIND),public:: convection_scheme !================================================================================================================= !wrf-variables:these variables are needed to keep calls to different physics parameterizations From ce4446ef791e37559bac8dd2ff6ae55fa845e33e Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 16 Feb 2017 14:41:29 -0700 Subject: [PATCH 20/28] * In ./src/core_atmosphere/physics, removed the local variable microp_scheme originally defined in mpas_atmphys_vars.F. microp_scheme is no longer needed and can be replaced with config_microp_scheme. --- .../mpas_atmphys_driver_microphysics.F | 71 +++++++++++++++---- .../physics/mpas_atmphys_init.F | 2 +- .../physics/mpas_atmphys_interface.F | 12 +++- .../physics/mpas_atmphys_manager.F | 13 ++-- .../physics/mpas_atmphys_vars.F | 9 +-- 5 files changed, 78 insertions(+), 29 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 6213dcc6a..7f55d0979 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -80,6 +80,9 @@ module mpas_atmphys_driver_microphysics ! * added parameterization of the WSM6 cloud microphysics from WRF version 3.8.1. To initialize WSM6 as in its ! original version, set the hail_option to 0. ! Laura D. Fowler (laura@ucar.edu) / 2016-09-19. +! * since we removed the local variable microp_scheme from mpas_atmphys_vars.F, now defines microp_scheme as a +! pointer to config_microp_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. !--- initialization option for WSM6 from WRF version 3.8.1. this option could also be set as a namelist parameter. integer,parameter:: hail_opt = 0 @@ -89,9 +92,19 @@ module mpas_atmphys_driver_microphysics !================================================================================================================= - subroutine allocate_microphysics + subroutine allocate_microphysics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: microp_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + !sounding variables: if(.not.allocated(rho_p) ) allocate(rho_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) ) @@ -153,9 +166,19 @@ subroutine allocate_microphysics end subroutine allocate_microphysics !================================================================================================================= - subroutine deallocate_microphysics + subroutine deallocate_microphysics(configs) !================================================================================================================= +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local pointers: + character(len=StrKIND),pointer:: microp_scheme + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + !sounding variables: if(allocated(rho_p) ) deallocate(rho_p ) if(allocated(th_p) ) deallocate(th_p ) @@ -217,19 +240,25 @@ subroutine deallocate_microphysics end subroutine deallocate_microphysics !================================================================================================================= - subroutine microphysics_init(dminfo,mesh,sfc_input,diag_physics) + subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) !================================================================================================================= !input arguments: type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: sfc_input !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics +!local pointer: + character(len=StrKIND),pointer:: microp_scheme + !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + microp_select: select case(microp_scheme) case("mp_thompson") @@ -263,6 +292,9 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend +!local pointers: + character(len=StrKIND),pointer:: microp_scheme + !local variables and arrays: logical:: log_microphysics integer:: i,icell,icount,istep,j,k,kk @@ -271,17 +303,19 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !write(0,*) !write(0,*) '---enter subroutine driver_microphysics:' + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + !... allocation of microphysics arrays: !$OMP MASTER - call allocate_microphysics + call allocate_microphysics(configs) !$OMP END MASTER !$OMP BARRIER !... initialization of precipitation related arrays: - call precip_from_MPAS(diag_physics,its,ite) + call precip_from_MPAS(configs,diag_physics,its,ite) !... initialization of soundings for non-hydrostatic dynamical cores. - call microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) + call microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) !... call to different cloud microphysics schemes: microp_select: select case(microp_scheme) @@ -354,7 +388,7 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !the computation of simulated radar reflectivity: if(trim(microp_scheme) == "mp_wsm6" .or. & trim(microp_scheme) == "mp_thompson") then - call compute_radar_reflectivity(diag_physics,its,ite) + call compute_radar_reflectivity(configs,diag_physics,its,ite) else write(0,*) '*** NOTICE: NOT computing simulated radar reflectivity' write(0,*) ' since WSM6 or Thompson microphysics scheme was not selected' @@ -371,12 +405,12 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !... copy updated cloud microphysics variables from the wrf-physics grid back to the geodesic- ! dynamics grid: - call microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) !... deallocation of all microphysics arrays: !$OMP BARRIER !$OMP MASTER - call deallocate_microphysics + call deallocate_microphysics(configs) !$OMP END MASTER !write(0,*) '---enter subroutine driver_microphysics:' @@ -385,16 +419,18 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten end subroutine driver_microphysics !================================================================================================================= - subroutine precip_from_MPAS(diag_physics,its,ite) + subroutine precip_from_MPAS(configs,diag_physics,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !output variables: type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,pointer:: nCellsSolve real,dimension(:),pointer:: graupelncv,rainncv,snowncv,sr @@ -403,6 +439,8 @@ subroutine precip_from_MPAS(diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) @@ -421,7 +459,7 @@ subroutine precip_from_MPAS(diag_physics,its,ite) enddo !variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) + microp_select: select case(microp_scheme) case ("mp_thompson","mp_wsm6") do j = jts, jte @@ -442,7 +480,7 @@ subroutine precip_from_MPAS(diag_physics,its,ite) case default - end select microp_select_init + end select microp_select end subroutine precip_from_MPAS @@ -452,13 +490,13 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) !input arguments: type(mpas_pool_type),intent(in):: configs - integer,intent(in):: its,ite !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,dimension(:),pointer:: i_rainnc real(kind=RKIND),pointer:: config_bucket_rainnc @@ -472,6 +510,7 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme ) call mpas_pool_get_config(configs,'config_bucket_rainnc',config_bucket_rainnc) call mpas_pool_get_array(diag_physics,'i_rainnc' ,i_rainnc ) @@ -537,16 +576,18 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) end subroutine precip_to_MPAS !================================================================================================================= - subroutine compute_radar_reflectivity(diag_physics,its,ite) + subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) !================================================================================================================= !input arguments: + type(mpas_pool_type),intent(in):: configs integer,intent(in):: its,ite !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme real(kind=RKIND),dimension(:),pointer:: refl10cm_max,refl10cm_1km,refl10cm_1km_max !local variables and arrays: @@ -556,6 +597,8 @@ subroutine compute_radar_reflectivity(diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(diag_physics,'refl10cm_max',refl10cm_max) call mpas_pool_get_array(diag_physics,'refl10cm_1km',refl10cm_1km) call mpas_pool_get_array(diag_physics,'refl10cm_1km_max',refl10cm_1km_max) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index e9d1e9cde..0b8021399 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -354,7 +354,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !initialization of cloud microphysics processes: if(config_microp_scheme .ne. 'off') & - call microphysics_init(dminfo,mesh,sfc_input,diag_physics) + call microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) !initialization of surface layer processes: if(config_sfclayer_scheme .ne. 'off') call init_sfclayer(configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index d1cf9fd73..4da74e0e3 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -470,10 +470,11 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite end subroutine MPAS_to_physics !================================================================================================================= - subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) + subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: diag @@ -483,6 +484,7 @@ subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) integer:: time_lev !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg integer,pointer:: index_ni,index_nr real(kind=RKIND),dimension(:),pointer :: nt_c,mu_c @@ -500,6 +502,8 @@ subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(mesh,'zgrid',zgrid) call mpas_pool_get_array(mesh,'zz' ,zz ) @@ -607,10 +611,11 @@ subroutine microphysics_from_MPAS(mesh,state,time_lev,diag,diag_physics,its,ite) end subroutine microphysics_from_MPAS !================================================================================================================= - subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) !================================================================================================================= !input variables: + type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh integer,intent(in):: itimestep,time_lev @@ -623,6 +628,7 @@ subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itime type(mpas_pool_type),intent(inout):: diag_physics !local pointers: + character(len=StrKIND),pointer:: microp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg integer,pointer:: index_ni,index_nr real(kind=RKIND),dimension(:),pointer :: surface_pressure,tend_sfc_pressure @@ -643,6 +649,8 @@ subroutine microphysics_to_MPAS(mesh,state,time_lev,diag,diag_physics,tend,itime !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_array(mesh,'zz' ,zz ) call mpas_pool_get_array(mesh,'zgrid',zgrid) diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index d25be8866..84d495ab1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -120,6 +120,9 @@ module mpas_atmphys_manager ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * in subroutine physics_run_init, removed the initialization of the local variable convection_scheme. ! convection_scheme is no longer needed and can be replaced with config_convection_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine physics_run_init, removed the initialization of the local variable microp_scheme. +! microp_scheme is no longer needed and can be replaced with config_microp_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -677,8 +680,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) num_months = nMonths num_soils = nSoilLevels - microp_scheme = trim(config_microp_scheme) - if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 !initialization of local physics time-steps: @@ -687,13 +688,13 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !... cloud microphysics: dt_microp = dt_dyn n_microp = 1 - if(trim(microp_scheme)=='mp_thompson') then + if(trim(config_microp_scheme)=='mp_thompson') then dt_microp = 90._RKIND n_microp = max(nint(dt_dyn/dt_microp),1) dt_microp = dt_dyn / n_microp if(dt_dyn <= dt_microp) dt_microp = dt_dyn endif - write(0,*) '--- specifics on cloud microphysics option microp_scheme = ',trim(microp_scheme) + write(0,*) '--- specifics on cloud microphysics option microp_scheme = ',trim(config_microp_scheme) write(0,*) '--- dt_microp = ', dt_microp write(0,*) '--- n_microp = ', n_microp !... convection: @@ -748,8 +749,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) has_reqi = 0 has_reqs = 0 if(config_microp_re) then - if(trim(microp_scheme)=='mp_thompson' .or. & - trim(microp_scheme)=='mp_wsm6') then + if(trim(config_microp_scheme)=='mp_thompson' .or. & + trim(config_microp_scheme)=='mp_wsm6') then if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(config_radt_sw_scheme)=='rrtmg_sw') then has_reqc = 1 has_reqi = 1 diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 5372bc226..012f63bef 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -92,14 +92,11 @@ module mpas_atmphys_vars ! * removed the initialization local variable convection_scheme. convection_scheme is no longer needed and can be ! replaced replaced with config_convection_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the initialization local variable microp_scheme. microp_scheme is no longer needed and can be +! replaced replaced with config_microp_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. -!================================================================================================================= -!list of physics parameterizations: -!================================================================================================================= - - character(len=StrKIND),public:: microp_scheme - !================================================================================================================= !wrf-variables:these variables are needed to keep calls to different physics parameterizations !as in wrf model. From c5906d42ec03163d4c62010457fe2d967bdccd43 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 19 Sep 2017 14:44:08 -0600 Subject: [PATCH 21/28] Fix broken builds with the PGI compilers The PGI compilers apparently need some module files from the ESMF timekeeping library when compiling code in the physics_wrf directory, and they also need the 'esmf_time' library when linking the build_tables utility program. Presumably, this is due to some indirect use of the ESMF modules that came with the use of the new logging system. --- src/core_atmosphere/physics/physics_wrf/Makefile | 4 ++-- src/core_atmosphere/utils/Makefile | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 3250ebaff..8480c1bd1 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -89,7 +89,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 885a4e23c..03034c741 100644 --- a/src/core_atmosphere/utils/Makefile +++ b/src/core_atmosphere/utils/Makefile @@ -4,7 +4,7 @@ all: build_tables mv build_tables ../../.. build_tables: build_tables.o atmphys_build_tables_thompson.o - $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework + $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) -L../../external/esmf_time_f90 -lesmf_time build_tables.o: \ From db7e226a1b4d275eb16a1a3a0c2b5b19ecd8aa16 Mon Sep 17 00:00:00 2001 From: raghuraj19 Date: Thu, 18 May 2017 19:28:26 -0700 Subject: [PATCH 22/28] Unified Code commit --- Makefile | 6 +- src/Makefile | 4 +- src/core_atmosphere/Makefile | 4 +- src/core_atmosphere/dynamics/Makefile | 2 +- .../dynamics/mpas_atm_time_integration.F | 3662 ++++++++++++----- src/framework/mpas_pool_routines.F | 326 +- 6 files changed, 2899 insertions(+), 1105 deletions(-) diff --git a/Makefile b/Makefile index baceb05cb..b569fe250 100644 --- a/Makefile +++ b/Makefile @@ -144,9 +144,9 @@ ifort: "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -FR" \ - "CFLAGS_OPT = -O3" \ - "CXXFLAGS_OPT = -O3" \ + "FFLAGS_OPT = -O3 -convert big_endian -FR -xMIC-AVX512" \ + "CFLAGS_OPT = -O3 -xMIC-AVX512" \ + "CXXFLAGS_OPT = -O3 -xMIC-AVX512" \ "LDFLAGS_OPT = -O3" \ "FFLAGS_DEBUG = -g -convert big_endian -FR -CU -CB -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ diff --git a/src/Makefile b/src/Makefile index cc0cc020d..e9991d762 100644 --- a/src/Makefile +++ b/src/Makefile @@ -15,7 +15,7 @@ endif all: mpas mpas: $(AUTOCLEAN_DEPS) externals frame ops dycore drver - $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time + $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -Mvect=noaltcode -acc -ta=tesla:cc60 externals: $(AUTOCLEAN_DEPS) ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" all ) @@ -25,7 +25,7 @@ drver: $(AUTOCLEAN_DEPS) externals frame ops dycore endif build_tools: externals - (cd tools; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CC="$(SCC)" CFLAGS="$(CFLAGS)") + (cd tools; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CC="$(SCC)" CFLAGS="-O") frame: $(AUTOCLEAN_DEPS) externals ( cd framework; $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" all ) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 2e77cf884..dbb86c876 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -1,7 +1,7 @@ .SUFFIXES: .F .o -PHYSICS=-DDO_PHYSICS -#PHYSICS= +#PHYSICS=-DDO_PHYSICS +PHYSICS= OBJS = mpas_atm_core.o \ mpas_atm_core_interface.o \ diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 97785deb4..14c68b183 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -18,5 +18,5 @@ ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -Mvect=noaltcode -acc -ta=tesla:cc60 -Minfo endif diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 7d5b8c01e..081c599ac 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -26,23 +26,27 @@ module atm_time_integration #endif use mpas_atm_iau - + use openacc integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables real (kind=RKIND), allocatable, dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics - +!$acc declare create(tend_ru_physics, tend_rtheta_physics, tend_rho_physics) ! Used in compute_dyn_tend real (kind=RKIND), allocatable, dimension(:,:) :: qtot +!$acc declare create(qtot) real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_w, delsq_divergence +!$acc declare create(delsq_theta, delsq_w, delsq_divergence) real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u ! real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation ! no longer used -> removed real (kind=RKIND), allocatable, dimension(:,:) :: delsq_vorticity real (kind=RKIND), allocatable, dimension(:,:) :: dpdz +!$acc declare create(delsq_u,delsq_vorticity,dpdz) ! Used in atm_advance_scalars real (kind=RKIND), dimension(:,:,:), allocatable :: horiz_flux_array + ! Used in atm_advance_scalars_mono real (kind=RKIND), dimension(:,:), allocatable :: scalar_old_arr, scalar_new_arr real (kind=RKIND), dimension(:,:), allocatable :: s_max_arr, s_min_arr @@ -57,6 +61,7 @@ module atm_time_integration ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex real (kind=RKIND), allocatable, dimension(:,:) :: ke_edge +!$acc declare create(ke_vertex,ke_edge) contains @@ -94,8 +99,8 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) if (trim(config_time_integration) == 'SRK3') then call atm_srk3(domain, dt, itimestep) else - call mpas_log_write('Unknown time integration option '//trim(config_time_integration), messageType=MPAS_LOG_ERR) - call mpas_log_write('Currently, only ''SRK3'' is supported.', messageType=MPAS_LOG_CRIT) + call mpas_dmpar_global_abort('Unknown time integration option '//trim(config_time_integration), deferredAbort=.true.) + call mpas_dmpar_global_abort('Currently, only ''SRK3'' is supported.') end if call mpas_set_time(currTime, dateTimeString=timeStamp) @@ -106,7 +111,7 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'xtime', xtime, 2) + call mpas_pool_get_array_gpu(state, 'xtime', xtime, 2) xtime = xtime_new block => block % next end do @@ -184,6 +189,7 @@ subroutine atm_srk3(domain, dt, itimestep) type (field2DReal), pointer :: pressure_p_field type (field2DReal), pointer :: rtheta_p_field type (field2DReal), pointer :: rtheta_pp_field + type (field2DReal), pointer :: divergence_3d_field type (field2DReal), pointer :: tend_u_field type (field2DReal), pointer :: u_field type (field2DReal), pointer :: w_field @@ -202,7 +208,15 @@ subroutine atm_srk3(domain, dt, itimestep) logical, parameter :: debug = .false. - + real (kind=RKIND), dimension(:,:), pointer :: gpu_theta_m_1, gpu_theta_m_2, gpu_pressure_p, gpu_rtheta_p, gpu_exner + real (kind=RKIND), dimension(:,:), pointer :: gpu_rtheta_pp, gpu_divergence_3d, gpu_u_1, gpu_u_2, gpu_w_1, gpu_w_2 + real (kind=RKIND), dimension(:,:), pointer :: gpu_tend_u, gpu_ru_p, gpu_rw_p, gpu_rho_pp, gpu_pv_edge, gpu_rho_edge + real (kind=RKIND), dimension(:,:,:), pointer :: gpu_scalars_1 + integer :: rrpk_rank, rrpk_devices, rrpk_local_gpu_id + rrpk_rank = domain % dminfo % my_proc_id + rrpk_devices = acc_get_num_devices(acc_device_nvidia) + rrpk_local_gpu_id = mod(rrpk_rank,rrpk_devices) + call acc_set_device_num(rrpk_local_gpu_id,acc_device_nvidia) ! ! Retrieve configuration options ! @@ -229,6 +243,11 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! Retrieve fields ! + call mpas_pool_get_array_gpu(state,'theta_m',gpu_theta_m_1,1) + call mpas_pool_get_array_gpu(state,'scalars',gpu_scalars_1,1) + call mpas_pool_get_array_gpu(diag,'pressure_p',gpu_pressure_p) + call mpas_pool_get_array_gpu(diag,'rtheta_p',gpu_rtheta_p) + call mpas_pool_get_field(state, 'theta_m', theta_m_field, 1) call mpas_pool_get_field(state, 'scalars', scalars_field, 1) call mpas_pool_get_field(diag, 'pressure_p', pressure_p_field) @@ -240,16 +259,17 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(state, 'nCells', nCells) call mpas_pool_get_dimension(state, 'nEdges', nEdges) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'nVertices', nVertices) allocate(qtot(nVertLevels,nCells+1)) - qtot(:,nCells+1) = 0.0_RKIND +! qtot(:,nCells+1) = 0.0_RKIND allocate(tend_rtheta_physics(nVertLevels,nCells+1)) - tend_rtheta_physics(:,nCells+1) = 0.0_RKIND +! tend_rtheta_physics(:,nCells+1) = 0.0_RKIND allocate(tend_rho_physics(nVertLevels,nCells+1)) - tend_rho_physics(:,nCells+1) = 0.0_RKIND +! tend_rho_physics(:,nCells+1) = 0.0_RKIND allocate(tend_ru_physics(nVertLevels,nEdges+1)) - tend_ru_physics(:,nEdges+1) = 0.0_RKIND - +! tend_ru_physics(:,nEdges+1) = 0.0_RKIND +!!$acc update device(qtot,tend_rtheta_physics,tend_rho_physics,tend_ru_physics) ! ! Initialize RK weights ! @@ -257,13 +277,13 @@ subroutine atm_srk3(domain, dt, itimestep) dynamics_split = config_dynamics_split if (config_split_dynamics_transport) then dt_dynamics = dt/real(dynamics_split) - call mpas_log_write(' split dynamics-transport integration $i', intArgs=(/dynamics_split/)) + write(0,*) ' split dynamics-transport integration ',dynamics_split else dynamics_split = 1 dt_dynamics = dt - call mpas_log_write(' coupled RK3 dynamics-transport integration ') + write(0,*) ' coupled RK3 dynamics-transport integration ' end if - if (.not. config_scalar_advection ) call mpas_log_write(' scalar advection turned off ') + if (.not. config_scalar_advection ) write(0,*) ' scalar advection turned off ' number_of_sub_steps = config_number_of_sub_steps @@ -296,7 +316,8 @@ subroutine atm_srk3(domain, dt, itimestep) number_sub_steps(3) = number_of_sub_steps end if - +!!$acc update host(gpu_theta_m_1,gpu_scalars_1,gpu_pressure_p,gpu_rtheta_p) +!$acc update host(gpu_theta_m_1,gpu_pressure_p,gpu_rtheta_p) ! theta_m call mpas_dmpar_exch_halo_field(theta_m_field) @@ -308,6 +329,8 @@ subroutine atm_srk3(domain, dt, itimestep) ! rtheta_p call mpas_dmpar_exch_halo_field(rtheta_p_field) +!!$acc update device(gpu_theta_m_1,gpu_scalars_1,gpu_pressure_p,gpu_rtheta_p) +!$acc update device(gpu_theta_m_1,gpu_pressure_p,gpu_rtheta_p) call mpas_timer_start('atm_rk_integration_setup') @@ -433,6 +456,16 @@ subroutine atm_srk3(domain, dt, itimestep) end do end if + allocate(delsq_theta(nVertLevels,nCells+1)) + allocate(delsq_w(nVertLevels,nCells+1)) + allocate(delsq_divergence(nVertLevels,nCells+1)) + allocate(delsq_u(nVertLevels,nEdges+1)) + allocate(delsq_vorticity(nVertLevels,nVertices+1)) + allocate(dpdz(nVertLevels,nCells+1)) + allocate(ke_vertex(nVertLevels,nVertices+1)) +! ke_vertex(:,nVertices+1) = 0.0_RKIND + allocate(ke_edge(nVertLevels,nEdges+1)) +! ke_edge(:,nEdges+1) = 0.0_RKIND DYNAMICS_SUBSTEPS : do dynamics_substep = 1, dynamics_split @@ -473,9 +506,11 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do call mpas_timer_stop('atm_compute_vert_imp_coefs') - + call mpas_pool_get_array_gpu(diag,'exner',gpu_exner) + !$acc update host(gpu_exner) call mpas_pool_get_field(diag, 'exner', exner_field) call mpas_dmpar_exch_halo_field(exner_field) + !$acc update device(gpu_exner) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -554,21 +589,21 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - allocate(delsq_theta(nVertLevels,nCells+1)) - delsq_theta(:,nCells+1) = 0.0_RKIND - allocate(delsq_w(nVertLevels,nCells+1)) - delsq_w(:,nCells+1) = 0.0_RKIND +! allocate(delsq_theta(nVertLevels,nCells+1)) +! delsq_theta(:,nCells+1) = 0.0_RKIND +! allocate(delsq_w(nVertLevels,nCells+1)) +! delsq_w(:,nCells+1) = 0.0_RKIND !! allocate(qtot(nVertLevels,nCells+1)) ! initializing this earlier in solution sequence - allocate(delsq_divergence(nVertLevels,nCells+1)) - delsq_divergence(:,nCells+1) = 0.0_RKIND - allocate(delsq_u(nVertLevels,nEdges+1)) - delsq_u(:,nEdges+1) = 0.0_RKIND +! allocate(delsq_divergence(nVertLevels,nCells+1)) +! delsq_divergence(:,nCells+1) = 0.0_RKIND +! allocate(delsq_u(nVertLevels,nEdges+1)) +! delsq_u(:,nEdges+1) = 0.0_RKIND !! allocate(delsq_circulation(nVertLevels,nVertices+1)) ! no longer used -> removed - allocate(delsq_vorticity(nVertLevels,nVertices+1)) - delsq_vorticity(:,nVertices+1) = 0.0_RKIND - allocate(dpdz(nVertLevels,nCells+1)) - dpdz(:,nCells+1) = 0.0_RKIND - +! allocate(delsq_vorticity(nVertLevels,nVertices+1)) +! delsq_vorticity(:,nVertices+1) = 0.0_RKIND +! allocate(dpdz(nVertLevels,nCells+1)) +! dpdz(:,nCells+1) = 0.0_RKIND +!!$acc update device(delsq_theta,delsq_w,delsq_divergence,delsq_u,delsq_vorticity,dpdz) !$OMP PARALLEL DO do thread=1,nThreads call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & @@ -581,14 +616,6 @@ subroutine atm_srk3(domain, dt, itimestep) end do !$OMP END PARALLEL DO - deallocate(delsq_theta) - deallocate(delsq_w) -!! deallocate(qtot) ! deallocation after dynamics step complete, see below - deallocate(delsq_divergence) - deallocate(delsq_u) -!! deallocate(delsq_circulation) ! no longer used -> removed - deallocate(delsq_vorticity) - deallocate(dpdz) block => block % next end do @@ -626,9 +653,11 @@ subroutine atm_srk3(domain, dt, itimestep) ! tend_u call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) + call mpas_pool_get_array_gpu(tend,'u',gpu_tend_u) +!$acc update host(gpu_tend_u) call mpas_pool_get_field(tend, 'u', tend_u_field) call mpas_dmpar_exch_halo_field(tend_u_field, (/ 1 /)) - +!$acc update device(gpu_tend_u) call mpas_timer_start('small_step_prep') block => domain % blocklist @@ -672,9 +701,11 @@ subroutine atm_srk3(domain, dt, itimestep) do small_step = 1, number_sub_steps(rk_step) call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag, 'rho_pp',gpu_rho_pp) +!$acc update host(gpu_rho_pp) call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) call mpas_dmpar_exch_halo_field(rho_pp_field, (/ 1 /)) - +!$acc update device(gpu_rho_pp) call mpas_timer_start('atm_advance_acoustic_step') block => domain % blocklist do while (associated(block)) @@ -725,37 +756,22 @@ subroutine atm_srk3(domain, dt, itimestep) ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag,'rtheta_pp',gpu_rtheta_pp) + call mpas_pool_get_array_gpu(diag,'divergence_3d',gpu_divergence_3d) +!$acc update host(gpu_rtheta_pp,gpu_divergence_3d) call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 1 /)) - -! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step - - call mpas_timer_start('atm_divergence_damping_3d') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - -!$OMP PARALLEL DO - do thread=1,nThreads - call atm_divergence_damping_3d( state, diag, mesh, block % configs, rk_sub_timestep(rk_step), & - edgeThreadStart(thread), edgeThreadEnd(thread) ) - end do -!$OMP END PARALLEL DO - - block => block % next - end do - call mpas_timer_stop('atm_divergence_damping_3d') + call mpas_pool_get_field(diag, 'divergence_3d', divergence_3d_field) + call mpas_dmpar_exch_halo_field(divergence_3d_field, (/ 1 /)) +!$acc update device(gpu_rtheta_pp,gpu_divergence_3d) end do ! end of acoustic steps loop !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag,'rw_p',gpu_rw_p) + call mpas_pool_get_array_gpu(diag,'ru_p',gpu_ru_p) +!$acc update host(gpu_rw_p,gpu_ru_p,gpu_rho_pp,gpu_rtheta_pp) call mpas_pool_get_field(diag, 'rw_p', rw_p_field) call mpas_dmpar_exch_halo_field(rw_p_field) @@ -770,6 +786,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 2 /)) +!$acc update device(gpu_rw_p,gpu_ru_p,gpu_rho_pp,gpu_rtheta_pp) call mpas_timer_start('atm_recover_large_step_variables') block => domain % blocklist do while (associated(block)) @@ -816,8 +833,11 @@ subroutine atm_srk3(domain, dt, itimestep) ! u !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /)) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_array_gpu(state, 'u',gpu_u_2, 2) +!$acc update host(gpu_u_2) call mpas_pool_get_field(state, 'u', u_field, 2) call mpas_dmpar_exch_halo_field(u_field) +!$acc update device(gpu_u_2) ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. @@ -962,22 +982,16 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - allocate(ke_vertex(nVertLevels,nVertices+1)) - ke_vertex(:,nVertices+1) = 0.0_RKIND - allocate(ke_edge(nVertLevels,nEdges+1)) - ke_edge(:,nEdges+1) = 0.0_RKIND - +!!$acc update device(ke_vertex,ke_edge) !$OMP PARALLEL DO do thread=1,nThreads - call atm_compute_solve_diagnostics(dt, state, 2, diag, mesh, block % configs, & + call atm_compute_solve_diagnostics_gpu(dt, state, 2, diag, mesh, block % configs, & cellThreadStart(thread), cellThreadEnd(thread), & vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), rk_step) end do !$OMP END PARALLEL DO - deallocate(ke_vertex) - deallocate(ke_edge) block => block % next end do @@ -986,18 +1000,25 @@ subroutine atm_srk3(domain, dt, itimestep) ! w call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_array_gpu(state, 'w', gpu_w_2, 2) +!$acc update host(gpu_w_2) call mpas_pool_get_field(state, 'w', w_field, 2) call mpas_dmpar_exch_halo_field(w_field) ! pv_edge call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_array_gpu(diag, 'pv_edge', gpu_pv_edge) +!$acc update host(gpu_pv_edge) call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) call mpas_dmpar_exch_halo_field(pv_edge_field) ! rho_edge + call mpas_pool_get_array_gpu(diag, 'rho_edge', gpu_rho_edge) +!$acc update host(gpu_rho_edge) call mpas_pool_get_field(diag, 'rho_edge', rho_edge_field) call mpas_dmpar_exch_halo_field(rho_edge_field) +!$acc update device(gpu_w_2,gpu_pv_edge,gpu_rho_edge) ! scalars if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then call mpas_pool_get_field(state, 'scalars', scalars_field, 2) @@ -1009,10 +1030,12 @@ subroutine atm_srk3(domain, dt, itimestep) if (dynamics_substep < dynamics_split) then call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) call mpas_pool_get_field(state, 'theta_m', theta_m_field, 2) - + call mpas_pool_get_array_gpu(state, 'theta_m', gpu_theta_m_2, 2) +!$acc update host(gpu_theta_m_2,gpu_pressure_p,gpu_rtheta_p) call mpas_dmpar_exch_halo_field(theta_m_field) call mpas_dmpar_exch_halo_field(pressure_p_field) call mpas_dmpar_exch_halo_field(rtheta_p_field) +!$acc update device(gpu_theta_m_2,gpu_pressure_p,gpu_rtheta_p) ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -1069,6 +1092,16 @@ subroutine atm_srk3(domain, dt, itimestep) end do DYNAMICS_SUBSTEPS + deallocate(ke_vertex) + deallocate(ke_edge) + deallocate(delsq_theta) + deallocate(delsq_w) +!! deallocate(qtot) ! deallocation after dynamics step complete, see below + deallocate(delsq_divergence) + deallocate(delsq_u) +!! deallocate(delsq_circulation) ! no longer used -> removed + deallocate(delsq_vorticity) + deallocate(dpdz) deallocate(qtot) ! we are finished with these now deallocate(tend_rtheta_physics) @@ -1225,18 +1258,21 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! reconstruct full velocity vectors at cell centers: ! + call mpas_timer_start('atm_rk_reconstruct') block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) - call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) - call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) - call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + call mpas_pool_get_array_gpu(state, 'u', u, 2) +! call mpas_pool_get_array_gpu(state, 'u', gpu_u_2, 2) +!!$acc update host(gpu_u_2) + call mpas_pool_get_array_gpu(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array_gpu(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array_gpu(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array_gpu(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array_gpu(diag, 'uReconstructMeridional', uReconstructMeridional) call mpas_reconstruct(mesh, u, & uReconstructX, & @@ -1248,6 +1284,7 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do + call mpas_timer_stop('atm_rk_reconstruct') ! ! call to parameterizations of cloud microphysics. calculation of the tendency of water vapor to horizontal and @@ -1264,8 +1301,8 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_array(state, 'scalars', scalars_1, 1) - call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_2, 2) call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) @@ -1277,7 +1314,7 @@ subroutine atm_srk3(domain, dt, itimestep) config_convection_scheme == 'cu_tiedtke' .or. & config_convection_scheme == 'cu_ntiedtke') then - call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + call mpas_pool_get_array_gpu(tend_physics, 'rqvdynten', rqvdynten) !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo @@ -1316,7 +1353,9 @@ subroutine atm_srk3(domain, dt, itimestep) ! #endif + call mpas_timer_start('atm_rk_summary') call summarize_timestep(domain) + call mpas_timer_stop('atm_rk_summary') end subroutine atm_srk3 @@ -1347,42 +1386,105 @@ subroutine atm_rk_integration_setup( state, diag, & real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2 real (kind=RKIND), dimension(:,:,:), pointer :: scalars_1, scalars_2 + integer, pointer :: num_scalars, nCells,nEdges,nVertLevels + + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_zz_old_split', rho_zz_old_split) + + call mpas_pool_get_array_gpu(state, 'u', u_1, 1) + call mpas_pool_get_array_gpu(state, 'u', u_2, 2) + call mpas_pool_get_array_gpu(state, 'w', w_1, 1) + call mpas_pool_get_array_gpu(state, 'w', w_2, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_1, 1) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_2, 2) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_2, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_2, 2) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) - - call mpas_pool_get_array(state, 'u', u_1, 1) - call mpas_pool_get_array(state, 'u', u_2, 2) - call mpas_pool_get_array(state, 'w', w_1, 1) - call mpas_pool_get_array(state, 'w', w_2, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) - call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) - call mpas_pool_get_array(state, 'scalars', scalars_1, 1) - call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - - ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) - rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) - rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) - rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) - - u_2(:,edgeStart:edgeEnd) = u_1(:,edgeStart:edgeEnd) - w_2(:,cellStart:cellEnd) = w_1(:,cellStart:cellEnd) - theta_m_2(:,cellStart:cellEnd) = theta_m_1(:,cellStart:cellEnd) - rho_zz_2(:,cellStart:cellEnd) = rho_zz_1(:,cellStart:cellEnd) - rho_zz_old_split(:,cellStart:cellEnd) = rho_zz_1(:,cellStart:cellEnd) - scalars_2(:,:,cellStart:cellEnd) = scalars_1(:,:,cellStart:cellEnd) - + call atm_rk_integration_setup_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, num_scalars, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2, & + scalars_1, scalars_2) end subroutine atm_rk_integration_setup + subroutine atm_rk_integration_setup_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, num_scalars, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2, & + scalars_1, scalars_2) + + implicit none + integer, intent(in) :: nVertLevels, edgeStart, edgeEnd,cellStart, cellEnd, & + nCells, nEdges, num_scalars + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw, rw_save + real (kind=RKIND), dimension(nVertLevels,nEdges+1):: ru, ru_save, u_1, u_2 + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: w_1,w_2 + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_p, rho_p_save, & + rtheta_p,rtheta_p_save, & + rho_zz_old_split, & + rho_zz_1, rho_zz_2, & + theta_m_1, theta_m_2 + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars_1, scalars_2 + integer:: i,j, k +!$acc data present(ru, ru_save, rw, rw_save, & +!$acc rtheta_p,rtheta_p_save,rho_p,rho_p_save, & +!$acc rho_zz_old_split, & +!$acc u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2) + +!!$acc update host(ru, ru_save, rw, rw_save, & +!!$acc rtheta_p,rtheta_p_save,rho_p,rho_p_save, & +!!$acc rho_zz_old_split, & +!!$acc u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2) +!$acc parallel vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels + rtheta_p_save(j,i) = rtheta_p(j,i) + rho_p_save(j,i) = rho_p(j,i) + theta_m_2(j,i) = theta_m_1(j,i) + rho_zz_2(j,i) = rho_zz_1(j,i) + rho_zz_old_split(j,i) = rho_zz_1(j,i) + do k=1,num_scalars + scalars_2(k,j,i) = scalars_1(k,j,i) + enddo + enddo +!$acc loop vector + do j=1,nVertLevels+1 + rw_save(j,i) = rw(j,i) + w_2(j,i) = w_1(j,i) + enddo + enddo +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ru_save(j,i) = ru(j,i) + u_2(j,i) = u_1(j,i) + enddo + enddo +!$acc end parallel + +!$acc end data + end subroutine atm_rk_integration_setup_work + subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -1401,52 +1503,77 @@ subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd integer :: iEdge, iCell, k, cell1, cell2, iq - integer, pointer :: nCells, nEdges, nVertLevels, nCellsSolve + integer, pointer :: pnCells, pnEdges, pnVertLevels, pnCellsSolve + integer :: nCells, nEdges, nVertLevels, nCellsSolve real (kind=RKIND) :: qtotal integer, dimension(:,:), pointer :: cellsOnEdge - integer, pointer :: moist_start, moist_end + integer, pointer :: pmoist_start, pmoist_end + integer :: moist_start, moist_end real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:), pointer :: cqw real (kind=RKIND), dimension(:,:), pointer :: cqu - call mpas_pool_get_dimension(dims, 'nCells', nCells) - call mpas_pool_get_dimension(dims, 'nEdges', nEdges) - call mpas_pool_get_dimension(dims, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'moist_start', moist_start) - call mpas_pool_get_dimension(state, 'moist_end', moist_end) - - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(state, 'scalars', scalars, 2) - call mpas_pool_get_array(diag, 'cqw', cqw) - call mpas_pool_get_array(diag, 'cqu', cqu) - -! do iCell = cellSolveStart,cellSolveEnd + call mpas_pool_get_dimension(dims, 'nCells', pnCells) + call mpas_pool_get_dimension(dims, 'nEdges', pnEdges) + call mpas_pool_get_dimension(dims, 'nVertLevels', pnVertLevels) + call mpas_pool_get_dimension(dims, 'nCellsSolve', pnCellsSolve) + call mpas_pool_get_dimension(state, 'moist_start', pmoist_start) + call mpas_pool_get_dimension(state, 'moist_end', pmoist_end) + + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) + call mpas_pool_get_array_gpu(diag, 'cqw', cqw) + call mpas_pool_get_array_gpu(diag, 'cqu', cqu) + + nCells = pnCells + nEdges = pnEdges + nVertLevels = pnVertLevels + nCellsSolve = pnCellsSolve + moist_start = pmoist_start + moist_end = pmoist_end + +!$acc data present(scalars,cqw,cqu, qtot) +!!$acc update host(scalars) +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do iCell = edgeStart,edgeEnd +!$acc loop vector + do k = 1,nVertLevels + tend_ru_physics(k,iCell) = 0.0_RKIND + end do + end do +!$acc end parallel +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang do iCell = cellStart,cellEnd - qtot(1:nVertLevels,iCell) = 0.0 +!$acc loop vector do k = 1,nVertLevels + qtot(k,iCell) = 0.0 + tend_rtheta_physics(k,iCell) = 0.0_RKIND + tend_rho_physics(k,iCell) = 0.0_RKIND +!$acc loop seq do iq = moist_start, moist_end qtot(k,iCell) = qtot(k,iCell) + scalars(iq, k, iCell) end do end do - end do - -! do iCell = cellSolveStart,cellSolveEnd - do iCell = cellStart,cellEnd +!$acc loop vector do k = 2, nVertLevels qtotal = 0.5*(qtot(k,iCell)+qtot(k-1,iCell)) cqw(k,iCell) = 1.0 / (1.0 + qtotal) end do end do +!$acc end parallel -! would need to compute qtot for all cells and an openmp barrier to use qtot below. - +!$acc parallel vector_length(32) +!$acc loop gang do iEdge = edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then - do k = 1, nVertLevels +!$acc loop vector + do k = 1, nVertLevels qtotal = 0.0 +!$acc loop seq do iq = moist_start, moist_end qtotal = qtotal + 0.5 * ( scalars(iq, k, cell1) + scalars(iq, k, cell2) ) end do @@ -1454,6 +1581,9 @@ subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & end do end if end do +!$acc end parallel +!!$acc update device(qtot,cqw,cqu) +!$acc end data end subroutine atm_compute_moist_coefficients @@ -1494,30 +1624,30 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d call mpas_pool_get_config(configs, 'config_epssm', epssm) - call mpas_pool_get_array(mesh, 'rdzu', rdzu) - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'zz', zz) - - call mpas_pool_get_array(diag, 'cqw', cqw) - call mpas_pool_get_array(diag, 'exner', p) - call mpas_pool_get_array(diag, 'exner_base', pb) - call mpas_pool_get_array(diag, 'rtheta_p', rt) - call mpas_pool_get_array(diag, 'rtheta_base', rtb) - call mpas_pool_get_array(diag, 'rho_base', rb) - - call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) - call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) - call mpas_pool_get_array(diag, 'a_tri', a_tri) - call mpas_pool_get_array(diag, 'cofwr', cofwr) - call mpas_pool_get_array(diag, 'cofwz', cofwz) - call mpas_pool_get_array(diag, 'coftz', coftz) - call mpas_pool_get_array(diag, 'cofwt', cofwt) - call mpas_pool_get_array(diag, 'cofrz', cofrz) - - call mpas_pool_get_array(state, 'theta_m', t, 2) - call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array_gpu(mesh, 'rdzu', rdzu) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdzw) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + + call mpas_pool_get_array_gpu(diag, 'cqw', cqw) + call mpas_pool_get_array_gpu(diag, 'exner', p) + call mpas_pool_get_array_gpu(diag, 'exner_base', pb) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rt) + call mpas_pool_get_array_gpu(diag, 'rtheta_base', rtb) + call mpas_pool_get_array_gpu(diag, 'rho_base', rb) + + call mpas_pool_get_array_gpu(diag, 'alpha_tri', alpha_tri) + call mpas_pool_get_array_gpu(diag, 'gamma_tri', gamma_tri) + call mpas_pool_get_array_gpu(diag, 'a_tri', a_tri) + call mpas_pool_get_array_gpu(diag, 'cofwr', cofwr) + call mpas_pool_get_array_gpu(diag, 'cofwz', cofwz) + call mpas_pool_get_array_gpu(diag, 'coftz', coftz) + call mpas_pool_get_array_gpu(diag, 'cofwt', cofwt) + call mpas_pool_get_array_gpu(diag, 'cofrz', cofrz) + + call mpas_pool_get_array_gpu(state, 'theta_m', t, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) call mpas_pool_get_dimension(state, 'nCells', nCells) call mpas_pool_get_dimension(state, 'moist_start', moist_start) @@ -1583,21 +1713,31 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! integer :: iCell, k, iq real (kind=RKIND) :: dtseps, c2, qtotal, rcv - real (kind=RKIND), dimension( nVertLevels ) :: b_tri, c_tri - + real (kind=RKIND), dimension( nVertLevels ,nCells+1) :: b_tri, c_tri +!$acc data present(cofrz, gamma_tri, a_tri, alpha_tri, & +!$acc coftz, cofwr, cofwt, cofwz, & +!$acc rdzw, cqw, fzm, fzp, p, pb, qtot, rb, rdzu, rt, rtb, t, zz)& +!$acc create(b_tri,c_tri) + ! set coefficients dtseps = .5*dts*(1.+epssm) rcv = rgas/(cp-rgas) c2 = cp*rcv + +!$acc parallel num_workers(8) vector_length(32) +!$acc loop vector ! MGD bad to have all threads setting this variable? do k=1,nVertLevels cofrz(k) = dtseps*rdzw(k) end do +!$acc end parallel - do iCell = cellSolveStart,cellSolveEnd ! we only need to do cells we are solving for, not halo cells +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd ! we only need to do cells we are solving for, not halo cells !DIR$ IVDEP do k=2,nVertLevels cofwr(k,iCell) =.5*dtseps*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) @@ -1610,48 +1750,65 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, coftz(k,iCell) = dtseps* (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) end do coftz(nVertLevels+1,iCell) = 0.0 + end do +!$acc end parallel + +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(qtotal) + do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP do k=1,nVertLevels -! qtotal = 0. -! do iq = moist_start, moist_end -! qtotal = qtotal + scalars(iq, k, iCell) -! end do qtotal = qtot(k,iCell) cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) -! cofwt(k,iCell) = 0. + end do + end do +!$acc end parallel +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd a_tri(1,iCell) = 0. ! note, this value is never used - b_tri(1) = 1. ! note, this value is never used - c_tri(1) = 0. ! note, this value is never used + b_tri(1,iCell) = 1. ! note, this value is never used + c_tri(1,iCell) = 0. ! note, this value is never used gamma_tri(1,iCell) = 0. alpha_tri(1,iCell) = 0. ! note, this value is never used + enddo +!$acc end parallel +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP do k=2,nVertLevels a_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k-1,iCell)*rdzw(k-1)*zz(k-1,iCell) & +cofwr(k ,iCell)* cofrz(k-1 ) & -cofwt(k-1,iCell)* coftz(k-1,iCell)*rdzw(k-1) - b_tri(k) = 1. & + b_tri(k,iCell) = 1. & +cofwz(k ,iCell)*(coftz(k ,iCell)*rdzw(k )*zz(k ,iCell) & +coftz(k ,iCell)*rdzw(k-1)*zz(k-1,iCell)) & -coftz(k ,iCell)*(cofwt(k ,iCell)*rdzw(k ) & -cofwt(k-1,iCell)*rdzw(k-1)) & +cofwr(k, iCell)*(cofrz(k )-cofrz(k-1)) - c_tri(k) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & + c_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & -cofwr(k ,iCell)* cofrz(k ) & +cofwt(k ,iCell)* coftz(k+1,iCell)*rdzw(k ) end do +! end do !MGD VECTOR DEPENDENCE +! do iCell = cellSolveStart,cellSolveEnd do k=2,nVertLevels - alpha_tri(k,iCell) = 1./(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) - gamma_tri(k,iCell) = c_tri(k)*alpha_tri(k,iCell) + alpha_tri(k,iCell) = 1./(b_tri(k,iCell)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) + gamma_tri(k,iCell) = c_tri(k,iCell)*alpha_tri(k,iCell) end do end do ! loop over cells +!$acc end parallel + +!$acc end data end subroutine atm_compute_vert_imp_coefs_work @@ -1694,40 +1851,40 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs, & call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - - call mpas_pool_get_array(tend, 'w', w_tend) - call mpas_pool_get_array(tend, 'u', u_tend) - - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - - call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - - call mpas_pool_get_array(diag, 'ru_p', ru_p) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'ru', ru) - - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) - - call mpas_pool_get_array(diag, 'rw_p', rw_p) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zb', zb) + call mpas_pool_get_array_gpu(mesh, 'zb3', zb3) + call mpas_pool_get_array_gpu(mesh, 'zb_cell', zb_cell) + call mpas_pool_get_array_gpu(mesh, 'zb3_cell', zb3_cell) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_array_gpu(tend, 'w', w_tend) + call mpas_pool_get_array_gpu(tend, 'u', u_tend) + + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + + call mpas_pool_get_array_gpu(diag, 'ru_p', ru_p) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + + call mpas_pool_get_array_gpu(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_pp_old', rtheta_pp_old) + + call mpas_pool_get_array_gpu(diag, 'rw_p', rw_p) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) call atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & nEdgesOnCell, cellsOnEdge, edgesOnCell, fzm, fzp, ruAvg, wwAvg, zb, zb3, zb_cell, zb3_cell, & @@ -1801,7 +1958,11 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & ! here we need to compute the omega tendency in a manner consistent with our diagnosis of omega. ! this requires us to use the same flux divergence as is used in the theta eqn - see Klemp et al MWR 2003. -!! do iCell=cellStart,cellEnd +!$acc data present(w_tend, & +!$acc edgesoncell, edgesoncell_sign, fzm, fzp,nedgesoncell, u_tend, & +!$acc zb3_cell, zb_cell, zz) +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(iEdge, flux) do iCell=cellSolveStart,cellSolveEnd do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -1817,6 +1978,8 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & w_tend(k,iCell) = ( fzm(k) * zz(k,iCell) + fzp(k) * zz(k-1,iCell) ) * w_tend(k,iCell) end do end do +!$acc end parallel +!$acc end data end subroutine atm_set_smlstep_pert_variables_work @@ -1854,7 +2017,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, wwAvg, rho_pp, cofwt, coftz, zxu, & a_tri, alpha_tri, gamma_tri, dss, & tend_ru, tend_rho, tend_rt, tend_rw, & - zgrid, cofwr, cofwz, w + zgrid, cofwr, cofwz, w, divergence_3d ! redefine ru_p to be perturbation from time t, change 3a ! temporary real (kind=RKIND), dimension(:,:), pointer :: ru @@ -1869,84 +2032,88 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign - real (kind=RKIND), pointer :: epssm + real (kind=RKIND), pointer :: epssm, smdiv, smdiv_p_forward real (kind=RKIND), pointer :: cf1, cf2, cf3 integer, pointer :: nEdges, nCellsSolve - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) -! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, 2) +! call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 1) ! change needed for rw_p, change 6 (see rayleigh damping) - call mpas_pool_get_array(state, 'w', w, 2) -! call mpas_pool_get_array(state, 'w', w, 1) - - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) - call mpas_pool_get_array(diag, 'ru_p', ru_p) - call mpas_pool_get_array(diag, 'rw_p', rw_p) - call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'cqu', cqu) - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array(diag, 'cofwt', cofwt) - call mpas_pool_get_array(diag, 'coftz', coftz) - call mpas_pool_get_array(diag, 'cofrz', cofrz) - call mpas_pool_get_array(diag, 'cofwr', cofwr) - call mpas_pool_get_array(diag, 'cofwz', cofwz) - call mpas_pool_get_array(diag, 'a_tri', a_tri) - call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) - call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) - - call mpas_pool_get_array(mesh, 'dss', dss) - - call mpas_pool_get_array(tend, 'u', tend_ru) - call mpas_pool_get_array(tend, 'rho_zz', tend_rho) - call mpas_pool_get_array(tend, 'theta_m', tend_rt) - call mpas_pool_get_array(tend, 'w', tend_rw) - - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zxu', zxu) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(state, 'w', w, 2) +! call mpas_pool_get_array_gpu(state, 'w', w, 1) + + call mpas_pool_get_array_gpu(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array_gpu(diag, 'rtheta_pp_old', rtheta_pp_old) + call mpas_pool_get_array_gpu(diag, 'ru_p', ru_p) + call mpas_pool_get_array_gpu(diag, 'rw_p', rw_p) + call mpas_pool_get_array_gpu(diag, 'exner', exner) + call mpas_pool_get_array_gpu(diag, 'cqu', cqu) + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array_gpu(diag, 'divergence_3d', divergence_3d) + call mpas_pool_get_array_gpu(diag, 'cofwt', cofwt) + call mpas_pool_get_array_gpu(diag, 'coftz', coftz) + call mpas_pool_get_array_gpu(diag, 'cofrz', cofrz) + call mpas_pool_get_array_gpu(diag, 'cofwr', cofwr) + call mpas_pool_get_array_gpu(diag, 'cofwz', cofwz) + call mpas_pool_get_array_gpu(diag, 'a_tri', a_tri) + call mpas_pool_get_array_gpu(diag, 'alpha_tri', alpha_tri) + call mpas_pool_get_array_gpu(diag, 'gamma_tri', gamma_tri) + + call mpas_pool_get_array_gpu(mesh, 'dss', dss) + + call mpas_pool_get_array_gpu(tend, 'u', tend_ru) + call mpas_pool_get_array_gpu(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array_gpu(tend, 'theta_m', tend_rt) + call mpas_pool_get_array_gpu(tend, 'w', tend_rw) + + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zxu', zxu) + call mpas_pool_get_array_gpu(mesh, 'zgrid', zgrid) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdzw) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(mesh, 'cf1', cf1) - call mpas_pool_get_array(mesh, 'cf2', cf2) - call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array_gpu(mesh, 'cf1', cf1) + call mpas_pool_get_array_gpu(mesh, 'cf2', cf2) + call mpas_pool_get_array_gpu(mesh, 'cf3', cf3) ! redefine ru_p to be perturbation from time t, change 3b ! temporary - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) ! redefine rw_p to be perturbation from time t, change 3b ! temporary - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) ! epssm is the offcentering coefficient for the vertically implicit integration. + ! smdiv is the 3D divergence-damping coefficients. call mpas_pool_get_config(configs, 'config_epssm', epssm) + call mpas_pool_get_config(configs, 'config_smdiv', smdiv) + call mpas_pool_get_config(configs, 'config_smdiv_p_forward', smdiv_p_forward) call atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & rho_zz, theta_m, ru_p, rw_p, rtheta_pp, rtheta_pp_old, zz, exner, cqu, ruAvg, wwAvg, & rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & - tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & + tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3 & + dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 & ) end subroutine atm_advance_acoustic_step @@ -1956,9 +2123,9 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & rho_zz, theta_m, ru_p, rw_p, rtheta_pp, rtheta_pp_old, zz, exner, cqu, ruAvg, wwAvg, & rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & - tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & + tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3 & + dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 & ) use mpas_atm_dimensions @@ -1980,6 +2147,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rtheta_pp real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rtheta_pp_old + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence_3d real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu @@ -2023,7 +2191,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign integer, intent(in) :: small_step - real (kind=RKIND), intent(in) :: dts, epssm,cf1, cf2, cf3 + real (kind=RKIND), intent(in) :: dts, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 real (kind=RKIND), dimension(nVertLevels) :: ts, rs @@ -2039,37 +2207,54 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart c2 = cp * rcv resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts + +!$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, divergence_3d, rho_pp, & +!$acc rw_p, wwavg, & +!$acc zz, cellsonedge, cqu, dcedge, exner, invdcedge, & +!$acc tend_ru, zxu, tend_rho, a_tri, alpha_tri, cofrz, & +!$acc coftz, cofwr, cofwt, cofwz, dss, dvedge, edgesoncell, edgesoncell_sign, & +!$acc fzm, fzp, gamma_tri, invareacell, nedgesoncell, rdzw, rho_zz, rw, & +!$acc rw_save, tend_rho, tend_rt, tend_rw, theta_m, w) if(small_step /= 1) then ! not needed on first small step - ! forward-backward acoustic step integration. - ! begin by updating the horizontal velocity u, - ! and accumulating the contribution from the updated u to the other tendencies. - - ! we are looping over all edges, but only computing on edges of owned cells. This will include updates of - ! all owned edges plus some edges that are owned by other blocks. We perform these redundant computations - ! so that we do not have to communicate updates of u to update the cell variables (rho, w, and theta). - - !MGD this loop will not be very load balanced with if-test below +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iCell = cellStart,cellEnd +!$acc loop vector + ! acoustic step divergence damping - forward weight rtheta_pp - see Klemp et al MWR 2007 + do k = 1,nVertLevels + rtheta_pp_tmp = rtheta_pp(k,iCell) + rtheta_pp(k,iCell) = (rtheta_pp(k,iCell) + smdiv_p_forward * (rtheta_pp(k,iCell)-rtheta_pp_old(k,iCell)))*zz(k,iCell) + rtheta_pp_old(k,iCell) = rtheta_pp_tmp + end do + end do +!$acc end parallel + +!$OMP BARRIER +!$acc parallel vector_length(32) +!$acc loop gang do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - + cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) ! update edges for block-owned cells if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) + ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) & + - smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) end do ! accumulate ru_p for use later in scalar transport !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) end do @@ -2077,9 +2262,13 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end if ! end test for block-owned cells end do ! end loop over edges +!$acc end parallel + end if - else ! this is all that us needed for ru_p update for first acoustic step in RK substep - + if(small_step ==1) then +! else ! this is all that us needed for ru_p update for first acoustic step in RK substep +!$acc parallel vector_length(32) +!$acc loop gang do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? cell1 = cellsOnEdge(1,iEdge) @@ -2087,34 +2276,41 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart ! update edges for block-owned cells if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - ru_p(k,iEdge) = dts*tend_ru(k,iEdge) + ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) end do !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels +!! ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) ruAvg(k,iEdge) = ru_p(k,iEdge) end do end if ! end test for block-owned cells end do ! end loop over edges - +!$acc end parallel end if ! test for first acoustic step +!$OMP BARRIER + if (small_step == 1) then ! initialize here on first small timestep. +!$acc parallel vector_length(32) +!$acc loop gang do iCell=cellStart,cellEnd rtheta_pp_old(1:nVertLevels,iCell) = 0.0 end do - else - do iCell=cellStart,cellEnd - rtheta_pp_old(1:nVertLevels,iCell) = rtheta_pp(1:nVertLevels,iCell) - end do +!$acc end parallel end if -!$OMP BARRIER +!!!OMP BARRIER -- not needed, since rtheta_pp_old not used below when small_step == 1 +!$acc parallel vector_length(32) +!$acc loop gang private(ts, rs) do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve +!!$acc cache(ts) +!!$acc cache(rs) ts(:) = 0.0 rs(:) = 0.0 @@ -2123,26 +2319,38 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart wwAvg(1:nVertLevels+1,iCell) = 0.0 rho_pp(1:nVertLevels,iCell) = 0.0 rtheta_pp(1:nVertLevels,iCell) = 0.0 +!MGD moved to loop above over all cells +! rtheta_pp_old(1:nVertLevels,iCell) = 0.0 rw_p(:,iCell) = 0.0 + divergence_3d(1:nVertLevels,iCell) = 0. + end if + if(small_step /= 1) then +! else ! reset rtheta_pp to input value; + ! rtheta_pp_old stores input value for use in div damping on next acoustic step. + ! Save rho_pp to compute d_rho_pp/dt to get divergence for next acoustic filter application. + rtheta_pp(1:nVertLevels,iCell) = rtheta_pp_old(1:nVertLevels,iCell) + divergence_3d(1:nVertLevels,iCell) = rho_pp(1:nVertLevels,iCell) end if - + +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels flux = edgesOnCell_sign(i,iCell)*dts*dvEdge(iEdge)*ru_p(k,iEdge) * invAreaCell(iCell) rs(k) = rs(k)-flux ts(k) = ts(k)-flux*0.5*(theta_m(k,cell2)+theta_m(k,cell1)) end do end do - ! vertically implicit acoustic and gravity wave integration. ! this follows Klemp et al MWR 2007, with the addition of an implicit Rayleigh damping of w ! serves as a gravity-wave absorbing layer, from Klemp et al 2008. !DIR$ IVDEP +!$acc loop vector do k=1, nVertLevels rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) @@ -2152,11 +2360,13 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do !DIR$ IVDEP +!$acc loop vector do k=2, nVertLevels wwavg(k,iCell) = wwavg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) end do !DIR$ IVDEP +!$acc loop vector do k=2, nVertLevels rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & @@ -2165,25 +2375,27 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & - cofwr(k,iCell)*((rs(k)+rs(k-1)) & +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & - + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & + + cofwt(k ,iCell)*(ts(k)+resm*rtheta_pp(k ,iCell)) & + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) end do ! tridiagonal solve sweeping up and then down the column !MGD VECTOR DEPENDENCE +!$acc loop seq do k=2,nVertLevels rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) end do !MGD VECTOR DEPENDENCE +!$acc loop seq do k=nVertLevels,1,-1 rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell) end do ! the implicit Rayleigh damping on w (gravity-wave absorbing) - !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels rw_p(k,iCell) = (rw_p(k,iCell) + (rw_save(k ,iCell) - rw(k ,iCell)) -dts*dss(k,iCell)* & (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) & @@ -2194,94 +2406,27 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart ! accumulate (rho*omega)' for use later in scalar transport !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) end do ! update rho_pp and theta_pp given updated rw_p - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & -coftz(k ,iCell)*rw_p(k ,iCell)) + divergence_3d(k,iCell) = (rho_pp(k,iCell) - divergence_3d(k,iCell))*rdts end do end do ! end of loop over cells - +!$acc end parallel +!$acc end data end subroutine atm_advance_acoustic_step_work - subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart, edgeEnd ) - - ! This subroutine updates the horizontal momentum with the 3d divergence damping component. - - implicit none - - type (mpas_pool_type), intent(inout) :: state - type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(inout) :: mesh - type (mpas_pool_type), intent(in) :: configs - real (kind=RKIND), intent(in) :: dts - integer, intent(in) :: edgeStart, edgeEnd - - real (kind=RKIND), dimension(:,:), pointer :: theta_m, ru_p, rtheta_pp, rtheta_pp_old -! real (kind=RKIND), dimension(:), pointer :: dcEdge - real (kind=RKIND), pointer :: smdiv, config_len_disp - - integer, dimension(:,:), pointer :: cellsOnEdge - integer, pointer :: nCellsSolve - integer, pointer :: nVertLevels - - real (kind=RKIND) :: divCell1, divCell2, rdts, coef_divdamp - integer :: cell1, cell2, iEdge, k - - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) -! call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) - call mpas_pool_get_array(diag, 'ru_p', ru_p) - - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_config(configs, 'config_smdiv', smdiv) - call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) - - rdts = 1.0_RKIND / dts - coef_divdamp = 2.0_RKIND * smdiv * config_len_disp * rdts - - do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - ! update edges for block-owned cells - if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then - -!DIR$ IVDEP - do k=1,nVertLevels - -!! unscaled 3d divergence damping -!! divCell1 = -(rtheta_pp(k,cell1)-rtheta_pp_old(k,cell1))*rdts -!! divCell2 = -(rtheta_pp(k,cell2)-rtheta_pp_old(k,cell2))*rdts -!! ru_p(k,iEdge) = ru_p(k,iEdge) + 2.*smdiv*dcEdge(iEdge)*(divCell2-divCell1) & -!! /(theta_m(k,cell1)+theta_m(k,cell2)) - -!! scaled 3d divergence damping - divCell1 = -(rtheta_pp(k,cell1)-rtheta_pp_old(k,cell1)) - divCell2 = -(rtheta_pp(k,cell2)-rtheta_pp_old(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1) & - /(theta_m(k,cell1)+theta_m(k,cell2)) - - end do - end if ! edges for block-owned cells - end do ! end loop over edges - - end subroutine atm_divergence_damping_3d - - subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, dt, ns, rk_step, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2322,49 +2467,49 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d real (kind=RKIND), pointer :: cf1, cf2, cf3 - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_p', rw_p) - call mpas_pool_get_array(state, 'w', w, 2) - - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) - call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) - call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_array(state, 'scalars', scalars, 2) - - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array(diag, 'rho_base', rho_base) - - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'ru_p', ru_p) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(state, 'u', u, 2) - - call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'exner_base', exner_base) - - call mpas_pool_get_array(diag, 'pressure_p', pressure_p) - call mpas_pool_get_array(diag, 'pressure_base', pressure_b) - - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_p', rw_p) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_pp', rtheta_pp) + call mpas_pool_get_array_gpu(diag, 'rtheta_base', rtheta_base) + call mpas_pool_get_array_gpu(tend, 'rt_diabatic_tend', rt_diabatic_tend) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) + + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array_gpu(diag, 'rho_base', rho_base) + + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'ru_p', ru_p) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(state, 'u', u, 2) + + call mpas_pool_get_array_gpu(diag, 'exner', exner) + call mpas_pool_get_array_gpu(diag, 'exner_base', exner_base) + + call mpas_pool_get_array_gpu(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array_gpu(diag, 'pressure_base', pressure_b) + + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zb', zb) + call mpas_pool_get_array_gpu(mesh, 'zb3', zb3) + call mpas_pool_get_array_gpu(mesh, 'zb_cell', zb_cell) + call mpas_pool_get_array_gpu(mesh, 'zb3_cell', zb3_cell) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(mesh, 'nCells', nCells) @@ -2372,9 +2517,9 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_array(mesh, 'cf1', cf1) - call mpas_pool_get_array(mesh, 'cf2', cf2) - call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array_gpu(mesh, 'cf1', cf1) + call mpas_pool_get_array_gpu(mesh, 'cf2', cf2) + call mpas_pool_get_array_gpu(mesh, 'cf3', cf3) call atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nEdgesSolve, dt, ns, rk_step, & @@ -2389,6 +2534,7 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d end subroutine atm_recover_large_step_variables + subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nEdgesSolve, dt, ns, rk_step, & wwAvg, rw_save, w, rw, rw_p, rtheta_p, rtheta_pp, rtheta_p_save, rt_diabatic_tend, rho_p, & rho_p_save, rho_pp, rho_zz, rho_base, ruAvg, ru_save, ru_p, u, ru, exner, exner_base, & @@ -2464,17 +2610,28 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE rcv = rgas/(cp-rgas) p0 = 1.0e+05 ! this should come from somewhere else... +!$acc data present(rho_zz, exner, pressure_p, rho_p, rtheta_p, rw, theta_m, w, & +!$acc wwavg, ru, ruavg, u, & +!$acc exner_base, fzm, fzp, rho_base, rho_p_save, rho_pp, rt_diabatic_tend, & +!$acc rtheta_base, rtheta_p_save, rtheta_pp, rw_p, rw_save, zz, cellsonedge, & +!$acc ru_p, ru_save, edgesoncell, edgesoncell_sign, nedgesoncell, zb3_cell, & +!$acc zb_cell) + ! Avoid FP errors caused by a potential division by zero below by ! initializing the "garbage cell" of rho_zz to a non-zero value +!$acc parallel num_workers(8) vector_length(32) +!$acc loop vector do k=1,nVertLevels rho_zz(k,nCells+1) = 1.0 end do - +!$acc end parallel ! compute new density everywhere so we can compute u from ru. ! we will also need it to compute theta_m below invNs = 1 / real(ns,RKIND) +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker do iCell=cellStart,cellEnd !DIR$ IVDEP @@ -2483,9 +2640,14 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE rho_zz(k,iCell) = rho_p(k,iCell) + rho_base(k,iCell) end do - + w(1,iCell) = 0.0 + end do +!$acc end parallel +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker + do iCell=cellStart,cellEnd !DIR$ IVDEP do k = 2, nVertLevels wwAvg(k,iCell) = rw_save(k,iCell) + (wwAvg(k,iCell) * invNs) @@ -2497,8 +2659,14 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do w(nVertLevels+1,iCell) = 0.0 + end do +!$acc end parallel + if (rk_step == 3) then +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker collapse(2) + do iCell=cellStart,cellEnd !DIR$ IVDEP do k = 1, nVertLevels rtheta_p(k,iCell) = rtheta_p_save(k,iCell) + rtheta_pp(k,iCell) & @@ -2509,15 +2677,24 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE pressure_p(k,iCell) = zz(k,iCell) * rgas * (exner(k,iCell)*rtheta_p(k,iCell)+rtheta_base(k,iCell) & * (exner(k,iCell)-exner_base(k,iCell))) end do - else + end do +!$acc end parallel + end if + + if (rk_step /= 3) then +! else +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker collapse(2) + do iCell=cellStart,cellEnd !DIR$ IVDEP do k = 1, nVertLevels rtheta_p(k,iCell) = rtheta_p_save(k,iCell) + rtheta_pp(k,iCell) theta_m(k,iCell) = (rtheta_p(k,iCell) + rtheta_base(k,iCell))/rho_zz(k,iCell) end do + end do +!$acc end parallel end if - end do ! recover time-averaged ruAvg on all edges of owned cells (for upcoming scalar transport). ! we solved for these in the acoustic-step loop. @@ -2525,6 +2702,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE !$OMP BARRIER +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(cell1, cell2) do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) @@ -2537,9 +2716,10 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE u(k,iEdge) = 2.*ru(k,iEdge)/(rho_zz(k,cell1)+rho_zz(k,cell2)) end do end do - +!$acc end parallel !$OMP BARRIER - +!$acc parallel num_workers(8) vector_length(32) +!$acc loop gang worker private(iEdge, flux) do iCell=cellStart,cellEnd ! finish recovering w from (rho*omega)_p. as when we formed (rho*omega)_p from u and w, we need @@ -2569,7 +2749,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do end do - +!$acc end parallel +!$acc end data end subroutine atm_recover_large_step_variables_work @@ -2637,38 +2818,38 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) - call mpas_pool_get_array(state, 'scalars', scalar_old, 1) - call mpas_pool_get_array(state, 'scalars', scalar_new, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - - call mpas_pool_get_array(diag, 'kdiff', kdiff) - call mpas_pool_get_array(diag, 'ruAvg', uhAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) - - call mpas_pool_get_array(mesh, 'fzm', fnm) - call mpas_pool_get_array(mesh, 'fzp', fnp) - call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) - - call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) - call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) - call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) - call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array_gpu(state, 'scalars', scalar_old, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalar_new, 2) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_old, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_new, 2) + + call mpas_pool_get_array_gpu(diag, 'kdiff', kdiff) + call mpas_pool_get_array_gpu(diag, 'ruAvg', uhAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array_gpu(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(tend, 'scalars_tend', scalar_tend_save) + + call mpas_pool_get_array_gpu(mesh, 'fzm', fnm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fnp) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdnw) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel4', meshScalingDel4) + + call mpas_pool_get_array_gpu(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + + call mpas_pool_get_array_gpu(diag, 'rho_edge', rho_edge) + call mpas_pool_get_array_gpu(mesh, 'qv_init', qv_init) + call mpas_pool_get_array_gpu(mesh, 'zgrid', zgrid) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -2720,6 +2901,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n end subroutine atm_advance_scalars + subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -2874,7 +3056,7 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm if (local_advance_density) then if ((.not.present(scalar_tend)) .or. (.not.present(rho_zz_int))) then - call mpas_log_write('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) + call mpas_dmpar_global_abort('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.') end if do iCell=cellSolveStart,cellSolveEnd @@ -3293,30 +3475,30 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(diag, 'ruAvg', uhAvg) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) - - call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(state, 'scalars', scalars_old, 1) - call mpas_pool_get_array(state, 'scalars', scalars_new, 2) - - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'fzm', fnm) - call mpas_pool_get_array(mesh, 'fzp', fnp) - call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) - call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) - call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) - call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array_gpu(diag, 'ruAvg', uhAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + + call mpas_pool_get_array_gpu(tend, 'scalars_tend', scalar_tend) + + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_old, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_new, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_old, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars_new, 2) + + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'fzm', fnm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fnp) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdnw) + call mpas_pool_get_array_gpu(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs_3rd', adv_coefs_3rd) call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -3331,6 +3513,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe end subroutine atm_advance_scalars_mono + subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels_dummy, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3484,7 +3667,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve if (local_advance_density) then if (.not.present(rho_zz_int)) then - call mpas_log_write('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) + call mpas_dmpar_global_abort('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.') end if ! begin with update of density @@ -3535,7 +3718,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_old(k,iCell)) end do end do - call mpas_log_write(' scmin, scmin old in $r $r', realArgs=(/scmin,scmax/)) + write(0,*) ' scmin, scmin old in ',scmin,scmax scmin = scalar_new(1,1) scmax = scalar_new(1,1) @@ -3545,7 +3728,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_new(k,iCell)) end do end do - call mpas_log_write(' scmin, scmin new in ', realArgs=(/scmin,scmax/)) + write(0,*) ' scmin, scmin new in ',scmin,scmax #endif @@ -3632,7 +3815,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then ! only for owned cells - ! special treatment of calculations involving edges between hexagonal cells + ! speclal treatment of calculations involving edges between hexagonal cells ! original code retained in select "default" case ! be sure to see additional declarations near top of subroutine select case(nAdvCellsForEdge(iEdge)) @@ -3666,8 +3849,6 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end select - else - flux_arr(:,iEdge) = 0.0_RKIND end if end do @@ -3887,15 +4068,15 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_new(k,iCell)) scmin = min(scmin,scalar_new(k,iCell)) if (s_max(k,iCell) < scalar_new(k,iCell)) then - call mpas_log_write(' over - k,iCell,s_min,s_max,scalar_new ', intArgs=(/k,iCell/), realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) + write(32,*) ' over - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell) end if if (s_min(k,iCell) > scalar_new(k,iCell)) then - call mpas_log_write(' under - k,iCell,s_min,s_max,scalar_new ', intArgs=(/k,iCell/), realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) + write(32,*) ' under - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell) end if end do end do - call mpas_log_write(' scmin, scmax new out $r $r', realArgs=(/scmin,scmax/)) - call mpas_log_write(' icell_min, k_min ', intArgs=(/icellmax, kmax/)) + write(0,*) ' scmin, scmax new out ',scmin,scmax + write(0,*) ' icell_min, k_min ',icellmax, kmax #endif ! the update should be positive definite. but roundoff can sometimes leave small negative values @@ -3994,7 +4175,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy - real (kind=RKIND), pointer :: coef_3rd_order, c_s + real (kind=RKIND), pointer :: coef_3rd_order, c_s, smdiv logical, pointer :: config_mix_full character (len=StrKIND), pointer :: config_horiz_mixing real (kind=RKIND), pointer :: config_del4u_div_factor @@ -4022,88 +4203,89 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_config(configs, 'config_visc4_2dsmag', config_visc4_2dsmag) call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) call mpas_pool_get_config(configs, 'config_smagorinsky_coef', c_s) + call mpas_pool_get_config(configs, 'config_smdiv', smdiv) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) - call mpas_pool_get_array(state, 'scalars', scalars, 2) - - call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) - call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(diag, 'rho_base', rb) - call mpas_pool_get_array(diag, 'rho_p', rr) - call mpas_pool_get_array(diag, 'rho_p_save', rr_save) - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(diag, 'kdiff', kdiff) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'divergence', divergence) - call mpas_pool_get_array(diag, 'vorticity', vorticity) - call mpas_pool_get_array(diag, 'ke', ke) - call mpas_pool_get_array(diag, 'pv_edge', pv_edge) - call mpas_pool_get_array(diag, 'pressure_p', pp) - call mpas_pool_get_array(diag, 'pressure_base', pressure_b) - call mpas_pool_get_array(diag, 'h_divergence', h_divergence) - call mpas_pool_get_array(diag, 'exner', exner) - - call mpas_pool_get_array(diag, 'tend_rtheta_adv', tend_rtheta_adv) - call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - - call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) - call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) - call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) - call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) - call mpas_pool_get_array(mesh, 'fEdge', fEdge) - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(mesh, 'zxu', zxu) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) - call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) - call mpas_pool_get_array(mesh, 'defc_a', defc_a) - call mpas_pool_get_array(mesh, 'defc_b', defc_b) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) - call mpas_pool_get_array(mesh, 'u_init', u_init) - call mpas_pool_get_array(mesh, 't_init', t_init) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - - call mpas_pool_get_array(mesh, 'rdzu', rdzu) - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - - call mpas_pool_get_array(tend, 'u', tend_u) - call mpas_pool_get_array(tend, 'theta_m', tend_theta) - call mpas_pool_get_array(tend, 'w', tend_w) - call mpas_pool_get_array(tend, 'rho_zz', tend_rho) - call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) - call mpas_pool_get_array(tend, 'u_euler', tend_u_euler) - call mpas_pool_get_array(tend, 'theta_euler', tend_theta_euler) - call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) - call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) - call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) - - call mpas_pool_get_array(diag, 'cqw', cqw) - call mpas_pool_get_array(diag, 'cqu', cqu) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array_gpu(state, 'u', u, 2) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_save, 1) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) + + call mpas_pool_get_array_gpu(diag, 'uReconstructZonal', ur_cell) + call mpas_pool_get_array_gpu(diag, 'uReconstructMeridional', vr_cell) + call mpas_pool_get_array_gpu(diag, 'rho_edge', rho_edge) + call mpas_pool_get_array_gpu(diag, 'rho_base', rb) + call mpas_pool_get_array_gpu(diag, 'rho_p', rr) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rr_save) + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(diag, 'kdiff', kdiff) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'divergence', divergence) + call mpas_pool_get_array_gpu(diag, 'vorticity', vorticity) + call mpas_pool_get_array_gpu(diag, 'ke', ke) + call mpas_pool_get_array_gpu(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array_gpu(diag, 'pressure_p', pp) + call mpas_pool_get_array_gpu(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array_gpu(diag, 'h_divergence', h_divergence) + call mpas_pool_get_array_gpu(diag, 'exner', exner) + + call mpas_pool_get_array_gpu(diag, 'tend_rtheta_adv', tend_rtheta_adv) + call mpas_pool_get_array_gpu(tend_physics, 'rthdynten', rthdynten) + + call mpas_pool_get_array_gpu(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array_gpu(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array_gpu(mesh, 'fEdge', fEdge) + call mpas_pool_get_array_gpu(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(mesh, 'zxu', zxu) + call mpas_pool_get_array_gpu(mesh, 'latCell', latCell) + call mpas_pool_get_array_gpu(mesh, 'latEdge', latEdge) + call mpas_pool_get_array_gpu(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array_gpu(mesh, 'defc_a', defc_a) + call mpas_pool_get_array_gpu(mesh, 'defc_b', defc_b) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel2', meshScalingDel2) + call mpas_pool_get_array_gpu(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array_gpu(mesh, 'u_init', u_init) + call mpas_pool_get_array_gpu(mesh, 't_init', t_init) + call mpas_pool_get_array_gpu(mesh, 'qv_init', qv_init) + + call mpas_pool_get_array_gpu(mesh, 'rdzu', rdzu) + call mpas_pool_get_array_gpu(mesh, 'rdzw', rdzw) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'zgrid', zgrid) + + call mpas_pool_get_array_gpu(tend, 'u', tend_u) + call mpas_pool_get_array_gpu(tend, 'theta_m', tend_theta) + call mpas_pool_get_array_gpu(tend, 'w', tend_w) + call mpas_pool_get_array_gpu(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array_gpu(tend, 'rt_diabatic_tend', rt_diabatic_tend) + call mpas_pool_get_array_gpu(tend, 'u_euler', tend_u_euler) + call mpas_pool_get_array_gpu(tend, 'theta_euler', tend_theta_euler) + call mpas_pool_get_array_gpu(tend, 'w_euler', tend_w_euler) + call mpas_pool_get_array_gpu(tend, 'w_pgf', tend_w_pgf) + call mpas_pool_get_array_gpu(tend, 'w_buoy', tend_w_buoy) + + call mpas_pool_get_array_gpu(diag, 'cqw', cqw) + call mpas_pool_get_array_gpu(diag, 'cqu', cqu) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -4118,15 +4300,15 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'moist_start', moist_start) call mpas_pool_get_dimension(state, 'moist_end', moist_end) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) - call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) - call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) - call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'advCellsForEdge', advCellsForEdge) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs', adv_coefs) + call mpas_pool_get_array_gpu(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - call mpas_pool_get_array(mesh, 'cf1', cf1) - call mpas_pool_get_array(mesh, 'cf2', cf2) - call mpas_pool_get_array(mesh, 'cf3', cf3) + call mpas_pool_get_array_gpu(mesh, 'cf1', cf1) + call mpas_pool_get_array_gpu(mesh, 'cf2', cf2) + call mpas_pool_get_array_gpu(mesh, 'cf3', cf3) ! ! rthdynten is currently associated with packages, and if those packages @@ -4139,8 +4321,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, rthdynten(:,nCells+1) = 0.0_RKIND inactive_rthdynten = .true. end if + + if(rk_step == 1) then - call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & + call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & @@ -4151,13 +4335,38 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & tend_rtheta_adv, rthdynten, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + + + else + call atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & + fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & + weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & + h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & + latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + tend_rtheta_adv, rthdynten, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + + end if + if (inactive_rthdynten) then deallocate(rthdynten) end if @@ -4165,6 +4374,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, end subroutine atm_compute_dyn_tend + subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & @@ -4176,7 +4386,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & tend_rtheta_adv, rthdynten, & @@ -4285,7 +4495,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy - real (kind=RKIND) :: coef_3rd_order, c_s + real (kind=RKIND) :: coef_3rd_order, c_s, smdiv logical :: config_mix_full character (len=StrKIND) :: config_horiz_mixing real (kind=RKIND) :: config_del4u_div_factor @@ -4305,24 +4515,26 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - ! + ! ! Local variables ! integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq, iAdvCell !real (kind=RKIND), parameter :: c_s = 0.125 - real (kind=RKIND), dimension( nVertLevels+1 ) :: d_diag, d_off_diag, flux_arr - real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx - real (kind=RKIND), dimension( nVertLevels ) :: ru_edge_w, q, u_mix + real (kind=RKIND), dimension( 64 ) :: d_diag, d_off_diag, flux_arr, ru_edge_w, tend_wk, delsq_wk, wduz, wdwz, wdtz, we_w, u_mix, h_wk + integer, dimension(15) :: iadv_cell_w + integer, dimension(64) :: eoe_w + real (kind=RKIND), dimension(15) :: coefs_w, coefs_3rd_w + real (kind=RKIND), dimension( nVertLevels + 1 ) :: dpzx real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r real (kind=RKIND) :: scalar_weight real (kind=RKIND) :: inv_r_earth - real (kind=RKIND) :: invDt, flux, workpv + real (kind=RKIND) :: invDt, flux, workpv, tendk real (kind=RKIND) :: edge_sign, pr_scale, r_dc, r_dv, u_mix_scale real (kind=RKIND) :: h_mom_eddy_visc4, v_mom_eddy_visc2 real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 - real (kind=RKIND) :: u_diffusion + real (kind=RKIND) :: u_diffusion, t_w, q1, q2 real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp @@ -4345,38 +4557,66 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm v_mom_eddy_visc2 = config_v_mom_eddy_visc2 v_theta_eddy_visc2 = config_v_theta_eddy_visc2 + rgas_cprcv = rgas*cp/cv + + +!$acc data present(kdiff, h_divergence, dpdz, tend_rho, tend_u_euler, & +!$acc tend_u, delsq_u, delsq_vorticity, delsq_divergence, & +!$acc tend_w, delsq_w, tend_w_euler, tend_theta, & +!$acc delsq_theta, tend_theta_euler, & +!$acc defc_a, defc_b, edgesoncell, nedgesoncell, u, v, & +!$acc dvedge, edgesoncell_sign, invareacell, ru, qtot, rb, rdzw, rr_save, rw, & +!$acc tend_rho_physics, cellsonedge, cqu, invdcedge, pp, zxu, zz, & +!$acc fzm, fzp, edgesonedge, ke, nedgesonedge, pv_edge, rho_edge, weightsonedge, & +!$acc divergence, invdvedge, meshscalingdel2, verticesonedge, vorticity, & +!$acc dcedge, edgesonvertex, edgesonvertex_sign, invareatriangle, & +!$acc meshscalingdel4, zgrid, angleedge, u_init, tend_ru_physics, adv_coefs, & +!$acc adv_coefs_3rd, advcellsforedge, nadvcellsforedge, w, cqw, rdzu, rho_zz, & +!$acc theta_m, theta_m_save, rt_diabatic_tend, tend_rtheta_physics, t_init, & +!$acc rw_save,tend_rtheta_adv) & +!$acc copy(rthdynten) - if (rk_step == 1) then - -! tend_u_euler(1:nVertLevels,edgeStart:edgeEnd) = 0.0 ! Smagorinsky eddy viscosity, based on horizontal deformation (in this case on model coordinate surfaces). ! The integration coefficients were precomputed and stored in defc_a and defc_b - - if(config_horiz_mixing == "2d_smagorinsky") then - do iCell = cellStart,cellEnd - d_diag(1:nVertLevels) = 0.0 - d_off_diag(1:nVertLevels) = 0.0 - do iEdge=1,nEdgesOnCell(iCell) - do k=1,nVertLevels - d_diag(k) = d_diag(k) + defc_a(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - end do +!!$acc kernels + +!$acc parallel vector_length(64) +if (config_horiz_mixing == "2d_smagorinsky") then +!$acc loop gang private(d_diag,d_off_diag) + do iCell = cellStart,cellEnd +!$acc cache(d_diag) +!$acc cache(d_off_diag) +!$acc loop vector + do k=1,nVertLevels + d_diag(k) = 0.0 + d_off_diag(k) = 0.0 + end do +!$acc loop seq + do iEdge=1,nEdgesOnCell(iCell) +!$acc loop vector + do k=1,nVertLevels + d_diag(k) = d_diag(k) + defc_a(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) end do + end do !DIR$ IVDEP - do k=1, nVertLevels - ! here is the Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity - kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) - end do +!$acc loop vector + do k=1, nVertLevels + kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) end do + end do - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 - else if(config_horiz_mixing == "2d_fixed") then + end if +!$acc end parallel + + ! else + if(config_horiz_mixing == "2d_fixed") then kdiff(1:nVertLevels,cellStart:cellEnd) = config_h_theta_eddy_visc2 h_mom_eddy_visc4 = config_h_mom_eddy_visc4 @@ -4384,51 +4624,57 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if - end if ! tendency for density. ! accumulate total water here for later use in w tendency calculation. ! accumulate horizontal mass-flux - do iCell=cellStart,cellEnd - h_divergence(1:nVertLevels,iCell) = 0.0 +!$acc parallel vector_length(64) +!$acc loop gang private(h_wk) + do iCell=cellStart,cellEnd +!$acc cache(h_wk) +!$acc loop vector + do k=1,nVertLevels + h_wk(k) = 0.0 + end do +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - h_divergence(k,iCell) = h_divergence(k,iCell) + edge_sign * ru(k,iEdge) + h_wk(k) = h_wk(k) + edge_sign * ru(k,iEdge) end do end do - end do - - ! compute horiontal mass-flux divergence, add vertical mass flux divergence to complete tend_rho - - do iCell = cellStart,cellEnd - r = invAreaCell(iCell) - do k = 1,nVertLevels - h_divergence(k,iCell) = h_divergence(k,iCell) * r +!$acc loop vector + do k=1,nVertLevels + r = invAreaCell(iCell) + h_divergence(k,iCell) = h_wk(k) * r end do - end do + end do +!$acc end parallel ! ! dp / dz and tend_rho ! ! only needed on first rk_step with pert variables defined a pert from time t ! - if(rk_step == 1) then - rgas_cprcv = rgas*cp/cv - do iCell = cellStart,cellEnd + ! rgas_cprcv = rgas*cp/cv +!$acc parallel vector_length(64) +!$acc loop gang + do iCell = cellStart,cellEnd !DIR$ IVDEP +!$acc loop vector do k = 1,nVertLevels tend_rho(k,iCell) = -h_divergence(k,iCell)-rdzw(k)*(rw(k+1,iCell)-rw(k,iCell)) + tend_rho_physics(k,iCell) dpdz(k,iCell) = -gravity*(rb(k,iCell)*(qtot(k,iCell)) + rr_save(k,iCell)*(1.+qtot(k,iCell))) end do end do - end if +!$acc end parallel !$OMP BARRIER @@ -4436,73 +4682,66 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Compute u (normal) velocity tendency for each edge (cell face) ! +!$acc parallel vector_length(64) +!$acc loop gang private(wduz, tend_wk, eoe_w, we_w) do iEdge=edgeSolveStart,edgeSolveEnd +!$acc cache(tend_wk) +!$acc cache(wduz) +!$acc cache(eoe_w) +!$acc cache(we_w) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) ! horizontal pressure gradient - - if(rk_step == 1) then -!DIR$ IVDEP - do k=1,nVertLevels - tend_u_euler(k,iEdge) = - cqu(k,iEdge)*( (pp(k,cell2)-pp(k,cell1))*invDcEdge(iEdge)/(.5*(zz(k,cell2)+zz(k,cell1))) & - -0.5*zxu(k,iEdge)*(dpdz(k,cell1)+dpdz(k,cell2)) ) - end do - - end if - - ! vertical transport of u - - wduz(1) = 0. - - k = 2 - wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - do k=3,nVertLevels-1 - wduz(k) = flux3( u(k-2,iEdge),u(k-1,iEdge),u(k,iEdge),u(k+1,iEdge),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) - end do - k = nVertLevels - wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - - wduz(nVertLevels+1) = 0. - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - tend_u(k,iEdge) = - rdzw(k)*(wduz(k+1)-wduz(k)) ! first use of tend_u + tend_u_euler(k,iEdge) = - cqu(k,iEdge) * & + ( (pp(k,cell2)-pp(k,cell1))*invDcEdge(iEdge)/ & + (.5*(zz(k,cell2)+zz(k,cell1))) & + -0.5*zxu(k,iEdge)*(dpdz(k,cell1)+dpdz(k,cell2)) ) + tend_wk(k) = u(k,iEdge) end do - ! Next, nonlinear Coriolis term (q) following Ringler et al JCP 2009 +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wduz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*tend_wk(k)+fzp(k)*tend_wk(k-1)) + end do +!$acc loop vector + do k=3,nVertLevels-1 + wduz(k) = flux3( tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) + end do - q(:) = 0.0 +!$acc loop vector shortloop do j = 1,nEdgesOnEdge(iEdge) - eoe = edgesOnEdge(j,iEdge) - do k=1,nVertLevels - workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe)) -! the original definition of pv_edge had a factor of 1/density. We have removed that factor -! given that it was not integral to any conservation property of the system - q(k) = q(k) + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv - end do + eoe_w(j) = edgesOnEdge(j,iEdge) + we_w(j) = weightsOnEdge(j,iEdge) end do !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - - ! horizontal ke gradient and vorticity terms in the vector invariant formulation - ! of the horizontal momentum equation - tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge)* (q(k) - (ke(k,cell2) - ke(k,cell1)) & - * invDcEdge(iEdge)) & - - u(k,iEdge)*0.5*(h_divergence(k,cell1)+h_divergence(k,cell2)) -#ifdef CURVATURE - ! curvature terms for the sphere - tend_u(k,iEdge) = tend_u(k,iEdge) & - - 2.*omega*cos(angleEdge(iEdge))*cos(latEdge(iEdge)) & - *rho_edge(k,iEdge)*.25*(w(k,cell1)+w(k+1,cell1)+w(k,cell2)+w(k+1,cell2)) & - - u(k,iEdge)*.25*(w(k+1,cell1)+w(k,cell1)+w(k,cell2)+w(k+1,cell2)) & - *rho_edge(k,iEdge) * inv_r_earth -#endif + q1 = pv_edge(k,iEdge) + q2 = 0.0 +!$acc loop seq + do j = 1,nEdgesOnEdge(iEdge) + eoe = eoe_w(j) + workpv = 0.5 * (q1 + pv_edge(k,eoe)) + q2 = q2 + we_w(j) * u(k,eoe) * workpv + end do + t_w = - rdzw(k)*(wduz(k+1)-wduz(k)) + tend_u(k,iEdge) = t_w + rho_edge(k,iEdge) * & + (q2 - (ke(k,cell2) - ke(k,cell1)) * & + invDcEdge(iEdge)) - tend_wk(k) * 0.5 * & + (h_divergence(k,cell1)+h_divergence(k,cell2)) end do - end do +!$acc end parallel ! @@ -4511,15 +4750,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. ! - if (rk_step == 1) then !$OMP BARRIER ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). ! First, storage to hold the result from the first del^2 computation. - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -4527,16 +4765,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm vertex2 = verticesOnEdge(2,iEdge) r_dc = invDcEdge(iEdge) r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + delsq_u(k,iEdge) = u_diffusion kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) @@ -4546,36 +4782,64 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do +!$acc end parallel - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - + if (h_mom_eddy_visc4 > 0.0) then !$OMP BARRIER - +!$acc parallel vector_length(64) +!$acc loop gang private(delsq_wk) do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 +!$acc cache(delsq_wk) +!$acc loop vector + do k=1,nVertLevels + delsq_wk(k) = 0.0 + end do +!$acc loop seq do i=1,vertexDegree iEdge = edgesOnVertex(i,iVertex) edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) +!$acc loop vector do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) + delsq_wk(k) = delsq_wk(k) + edge_sign * delsq_u(k,iEdge) end do end do +!$acc loop vector + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_wk(k) + end do end do +!$acc end parallel +!$acc parallel vector_length(64) +!$acc loop gang private(delsq_wk) do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 +!$acc cache(delsq_wk) +!$acc loop vector + do k=1,nVertLevels + delsq_wk(k) = 0.0 + end do r = invAreaCell(iCell) +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) +!$acc loop vector do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) + delsq_wk(k) = delsq_wk(k) + edge_sign * delsq_u(k,iEdge) end do end do +!$acc loop vector + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_wk(k) + end do end do +!$acc end parallel + end if + if (h_mom_eddy_visc4 > 0.0) then !$OMP BARRIER - +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -4587,6 +4851,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity @@ -4596,27 +4861,28 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! relative to the rotational part. The stability constraint on the divergence component is much less ! stringent than the rotational part, and this flexibility may be useful. ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - end do end do - - end if ! 4th order mixing is active +!$acc end parallel + end if ! ! vertical mixing for u - 2nd order filter in physical (z) space ! if ( v_mom_eddy_visc2 > 0.0 ) then - if (config_mix_full) then ! mix full state +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) +!$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -4633,22 +4899,27 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) end do end do +!$acc end parallel + end if - else ! idealized cases where we mix on the perturbation from the initial 1-D state - + if (.not. config_mix_full) then ! mix full state + !else ! idealized cases where we mix on the perturbation from the initial 1-D state +!$acc parallel vector_length(64) +!$acc loop gang private(u_mix) do iEdge=edgeSolveStart,edgeSolveEnd +!$acc cache(u_mix) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) +!$acc loop vector do k=1,nVertLevels -#ifdef ROTATED_GRID - u_mix(k) = u(k,iEdge) - u_init(k) * sin( angleEdge(iEdge) ) -#else + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) -#endif + end do +!$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -4666,23 +4937,25 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do +!$acc end parallel end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum - end if ! (rk_step 1 test for computing mixing terms) !$OMP BARRIER ! add in mixing for u +!$acc parallel vector_length(64) +!$acc loop gang do iEdge=edgeSolveStart,edgeSolveEnd !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels -! tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) - tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) + tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) end do end do +!$acc end parallel !----------- rhs for w @@ -4692,58 +4965,74 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! horizontal advection for w ! +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - tend_w(1:nVertLevels+1,iCell) = 0.0 +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) - edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * 0.5 - +!$acc loop vector do k=2,nVertLevels ru_edge_w(k) = fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) end do - flux_arr(1:nVertLevels) = 0.0 +!$acc loop vector + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop vector + do k=1,nVertLevels + flux_arr(k) = 0.0 + end do - ! flux_arr stores the value of w at the cell edge used in the horizontal transport + ! flux_arr stores the value of w at the cell edge used in the + ! horizontal transport +!$acc loop seq do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) +!$acc loop vector do k=2,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,ru_edge_w(k)) * adv_coefs_3rd(j,iEdge) + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k)) * coefs_3rd_w(j) flux_arr(k) = flux_arr(k) + scalar_weight * w(k,iAdvCell) end do end do !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) - edgesOnCell_sign(i,iCell) * ru_edge_w(k)*flux_arr(k) + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell)*ru_edge_w(k)*flux_arr(k) end do - end do - end do -#ifdef CURVATURE - do iCell = cellSolveStart, cellSolveEnd !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) + (rho_zz(k,iCell)*fzm(k)+rho_zz(k-1,iCell)*fzp(k))* & - ( (fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell))**2. & - +(fzm(k)*vr_cell(k,iCell)+fzp(k)*vr_cell(k-1,iCell))**2. )/r_earth & - + 2.*omega*cos(latCell(iCell)) & - *(fzm(k)*ur_cell(k,iCell)+fzp(k)*ur_cell(k-1,iCell)) & - *(rho_zz(k,iCell)*fzm(k)+rho_zz(k-1,iCell)*fzp(k)) - + tend_w(k,iCell) = tend_wk(k) end do end do -#endif - +!$acc end parallel ! ! horizontal mixing for w - we could combine this with advection directly (i.e. as a turbulent flux), ! but here we can also code in hyperdiffusion if we wish (2nd order at present) ! - if (rk_step == 1) then ! !OMP BARRIER why is this openmp barrier here??? @@ -4752,12 +5041,21 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. - - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 - +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, delsq_wk) do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 +!$acc cache(tend_wk) +!$acc cache(delsq_wk) + r_areaCell = invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels+1 + delsq_wk(k) = 0.0 + tend_wk(k) = 0.0 + end do + +! BDL could do something here with edgesOnCell and edgesOnCell_sign +!$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -4767,41 +5065,60 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_wk(k) = delsq_wk(k) + w_turb_flux w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + tend_wk(k) = tend_wk(k) + w_turb_flux end do end do +!$acc loop vector + do k=1,nVertLevels + delsq_w(k,iCell) = delsq_wk(k) + tend_w_euler(k,iCell) = tend_wk(k) + end do end do +!$acc end parallel -!$OMP BARRIER - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active +!$OMP BARRIER - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + if(h_mom_eddy_visc4 > 0.0) then +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(tend_wk) + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels + tend_wk(k) = tend_w_euler(k,iCell) + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do - +!$acc loop vector + do k=2,nVertLevels + tend_wk(k) = tend_wk(k) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) end do - end do - - end if ! 4th order mixing is active + end do +!$acc loop vector + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel end if ! horizontal mixing for w computed in first rk_step + ! Note for OpenMP parallelization: We could avoid allocating the delsq_w scratch ! array, and just use the delsq_theta array as was previously done; however, ! particularly when oversubscribing cores with threads, there is the risk that @@ -4813,258 +5130,1371 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! vertical advection, pressure gradient and buoyancy for w ! +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, wdwz) do iCell=cellSolveStart,cellSolveEnd - wdwz(1) = 0.0 +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = w(k,iCell) + end do - k = 2 - wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell)) +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdwz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wdwz(k) = 0.25*(rw(k,iCell)+rw(k-1,iCell))*(tend_wk(k)+tend_wk(k-1)) + end do +!$acc loop vector do k=3,nVertLevels-1 - wdwz(k) = flux3( w(k-2,iCell),w(k-1,iCell),w(k,iCell),w(k+1,iCell),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) + wdwz(k) = flux3(tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) end do - k = nVertLevels - wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell)) - - wdwz(nVertLevels+1) = 0.0 - - ! Note: next we are also dividing through by the cell area after the horizontal flux divergence !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) -rdzu(k)*(wdwz(k+1)-wdwz(k)) + tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) - rdzu(k)*(wdwz(k+1)-wdwz(k)) end do - if(rk_step == 1) then !DIR$ IVDEP - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - cqw(k,iCell)*( & +!$acc loop vector + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - cqw(k,iCell)*( & rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) & - (fzm(k)*dpdz(k,iCell) + fzp(k)*dpdz(k-1,iCell)) ) ! dpdz is the buoyancy term here. end do - end if - end do - - if (rk_step == 1) then +!$acc end parallel if ( v_mom_eddy_visc2 > 0.0 ) then - +!$acc parallel vector_length(64) +!$acc loop gang do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP +!$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) end do end do - +!$acc end parallel end if - end if ! mixing term computed first rk_step +!$acc parallel vector_length(64) +!$acc loop gang + do iCell = cellSolveStart,cellSolveEnd +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) + end do + end do +!$acc end parallel + +!----------- rhs for theta + + ! + ! horizontal advection for theta + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + +!$acc loop vector + do k=1,nVertLevels + ru_edge_w(k) = ru(k,iEdge) + flux_arr(k) = 0.0 + end do + +!$acc loop vector shortloop + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) +!$acc loop vector + do k=1,nVertLevels + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k))*coefs_3rd_w(j) + flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell) * ru_edge_w(k) * flux_arr(k) + end do + + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + + ! + ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), + ! but here we can also code in hyperdiffusion if we wish (2nd order at present) + ! +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, delsq_wk) + do iCell=cellStart,cellEnd +!$acc cache(tend_wk) +!$acc cache(delsq_wk) + + r_areaCell = invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels + delsq_wk(k) = 0.0 + tend_wk(k) = 0.0 + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP +!$acc loop vector + do k = 1, nVertLevels + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_wk(k) = delsq_wk(k) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale + tend_wk(k) = tend_wk(k) + theta_turb_flux + end do + end do +!DIR$ IVDEP +!$acc loop vector + do k = 1, nVertLevels + delsq_theta(k,iCell) = delsq_wk(k) + tend_theta_euler(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + + +!$OMP BARRIER + + if(h_theta_eddy_visc4 > 0.0) then +!$acc parallel vector_length(64) private(tend_wk) +!$acc loop gang + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(tend_wk) + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) +!$acc loop vector + do k = 1, nVertLevels + tend_wk(k) = tend_theta_euler(k,iCell) + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_wk(k) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + + end do +!$acc loop vector + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + end if ! theta mixing calculated first rk_step + + + ! + ! vertical advection plus diabatic term + ! Note: we are also dividing through by the cell area after the horizontal flux divergence + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(wdtz) + do iCell = cellSolveStart,cellSolveEnd +!$acc cache(wdtz) + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdtz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + if (k.eq.2) then + wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) + wdtz(k) = wdtz(k)+(rw_save(k,icell)-rw(k,icell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) + else + wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) !rtheta_pp redefinition + end if + end do +!$acc loop vector + do k=3,nVertLevels-1 + wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) + wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) ! rtheta_pp redefinition + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) + tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme + rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme + tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) + end do + end do +!$acc end parallel + + ! + ! vertical mixing for theta - 2nd order + ! + + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m +!$acc parallel num_gangs(256) num_workers(4) vector_length(32) + if (config_mix_full) then +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + end if +!$acc end parallel + +!$acc parallel num_gangs(256) num_workers(4) vector_length(32) + if (.not.config_mix_full) then + !else ! idealized cases where we mix on the perturbation from the initial 1-D state +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do - ! add in mixing terms for w + end if +!$acc end parallel + end if +!$acc parallel vector_length(64) +!$acc loop gang do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP - do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) + end do + end do +!$acc end parallel +!$acc end data + end subroutine atm_compute_dyn_tend_work + + subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels_dummy, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & + fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & + weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & + h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & + latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, smdiv, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + tend_rtheta_adv, rthdynten, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + + USE mpas_atm_dimensions + + + implicit none + + + ! + ! Dummy arguments + ! + integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end + + real (kind=RKIND), dimension(nEdges+1) :: fEdge + real (kind=RKIND), dimension(nEdges+1) :: dvEdge + real (kind=RKIND), dimension(nEdges+1) :: dcEdge + real (kind=RKIND), dimension(nEdges+1) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1) :: invDvEdge + real (kind=RKIND), dimension(nCells+1) :: invAreaCell + real (kind=RKIND), dimension(nVertices+1) :: invAreaTriangle + real (kind=RKIND), dimension(nEdges+1) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1) :: meshScalingDel4 + real (kind=RKIND), dimension(maxEdges2,nEdges+1) :: weightsOnEdge + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: zgrid + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: rho_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ru + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: v + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: tend_u + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rho + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rt_diabatic_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_theta + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: cqw + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rb + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rr + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: pp + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: pressure_b + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: zxu + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff + real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ru_save + + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m_save + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rr_save + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: tend_u_euler + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_euler + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_theta_euler + real (kind=RKIND), dimension(15,2,nEdges+1) :: deriv_two + integer, dimension(2,nEdges+1) :: cellsOnEdge + integer, dimension(2,nEdges+1) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1) :: edgesOnCell + integer, dimension(maxEdges2,nEdges+1) :: edgesOnEdge + integer, dimension(maxEdges,nCells+1) :: cellsOnCell + integer, dimension(vertexDegree,nVertices+1) :: edgesOnVertex + integer, dimension(nCells+1) :: nEdgesOnCell + integer, dimension(nEdges+1) :: nEdgesOnEdge + real (kind=RKIND), dimension(nCells+1) :: latCell + real (kind=RKIND), dimension(nEdges+1) :: latEdge + real (kind=RKIND), dimension(nEdges+1) :: angleEdge + real (kind=RKIND), dimension(nVertLevels) :: u_init + + integer, dimension(15,nEdges+1) :: advCellsForEdge + integer, dimension(nEdges+1) :: nAdvCellsForEdge + real (kind=RKIND), dimension(15,nEdges+1) :: adv_coefs + real (kind=RKIND), dimension(15,nEdges+1) :: adv_coefs_3rd + + real (kind=RKIND), dimension(nVertLevels) :: rdzu + real (kind=RKIND), dimension(nVertLevels) :: rdzw + real (kind=RKIND), dimension(nVertLevels) :: fzm + real (kind=RKIND), dimension(nVertLevels) :: fzp + real (kind=RKIND), dimension(nVertLevels) :: qv_init + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: t_init + + real (kind=RKIND) :: cf1, cf2, cf3 + real (kind=RKIND) :: prandtl_inv, r_areaCell, rgas_cprcv + + real (kind=RKIND) :: r_earth + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ur_cell + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: vr_cell + + real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_a + real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_b + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy + + real (kind=RKIND) :: coef_3rd_order, c_s, smdiv + logical :: config_mix_full + character (len=StrKIND) :: config_horiz_mixing + real (kind=RKIND) :: config_del4u_div_factor + real (kind=RKIND) :: config_h_theta_eddy_visc4 + real (kind=RKIND) :: config_h_mom_eddy_visc4 + real (kind=RKIND) :: config_visc4_2dsmag + real (kind=RKIND) :: config_len_disp + real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 + + integer, intent(in) :: rk_step + real (kind=RKIND), intent(in) :: dt + + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rtheta_adv + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rthdynten + + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + + ! + ! Local variables + ! + integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq, iAdvCell + + !real (kind=RKIND), parameter :: c_s = 0.125 + real (kind=RKIND), dimension( 64 ) :: d_diag, d_off_diag,flux_arr1, flux_arr, ru_edge_w, ru_save_temp , tend_wk, delsq_wk, wduz, wdwz, wdtz, we_w, u_mix, h_wk + integer, dimension(15) :: iadv_cell_w + integer, dimension(64) :: eoe_w + real (kind=RKIND), dimension(15) :: coefs_w, coefs_3rd_w + real (kind=RKIND), dimension( nVertLevels + 1 ) :: dpzx + real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r + real (kind=RKIND) :: scalar_weight + real (kind=RKIND) :: inv_r_earth + + real (kind=RKIND) :: invDt, flux, workpv, tendk + real (kind=RKIND) :: edge_sign, pr_scale, r_dc, r_dv, u_mix_scale + real (kind=RKIND) :: h_mom_eddy_visc4, v_mom_eddy_visc2 + real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 + real (kind=RKIND) :: u_diffusion, t_w, q1, q2 + + real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp + + + + real (kind=RKIND) :: flux3, flux4 + real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + + flux3(q_im2, q_im1, q_i, q_ip1, ua, coef3) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + + + prandtl_inv = 1.0_RKIND / prandtl + invDt = 1.0_RKIND / dt + inv_r_earth = 1.0_RKIND / r_earth + + v_mom_eddy_visc2 = config_v_mom_eddy_visc2 + v_theta_eddy_visc2 = config_v_theta_eddy_visc2 + +!$acc data present(cellsonedge,dvedge,edgesoncell, & +!$acc tend_ru_physics, & +!$acc tend_rtheta_physics, & +!$acc edgesoncell_sign,fzm,fzp,invareacell,nedgesoncell & +!$acc ,ru,rw,u,edgesonedge, & +!$acc invdcedge,ke,nedgesonedge, & +!$acc pv_edge,rdzw,rho_edge, & +!$acc weightsonedge,adv_coefs,adv_coefs_3rd,advcellsforedge, & +!$acc w,rdzu, tend_w_euler, & +!$acc theta_m,ru_save,theta_m_save,tend_u_euler, & +!$acc nadvcellsforedge,rho_zz, & +!$acc rt_diabatic_tend,rw_save, & +!$acc tend_theta_euler, & +!$acc h_divergence,tend_u, & +!$acc tend_theta,tend_w,& +!$acc tend_rtheta_adv) & +!$acc copy(rthdynten) + + + + + ! tendency for density. + ! accumulate total water here for later use in w tendency calculation. + + ! accumulate horizontal mass-flux +!$acc parallel vector_length(64) +!$acc loop gang private(h_wk) + do iCell=cellStart,cellEnd +!$acc cache(h_wk) +!$acc loop vector + do k=1,nVertLevels + h_wk(k) = 0.0 + end do +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + h_wk(k) = h_wk(k) + edge_sign * ru(k,iEdge) + end do + end do +!$acc loop vector + do k=1,nVertLevels + r = invAreaCell(iCell) + h_divergence(k,iCell) = h_wk(k) * r + end do + end do +!$acc end parallel + + + + ! + ! dp / dz and tend_rho + ! + ! only needed on first rk_step with pert variables defined a pert from time t + ! +!$OMP BARRIER + ! + ! Compute u (normal) velocity tendency for each edge (cell face) + ! +!$acc parallel vector_length(64) +!$acc loop gang private(wduz, tend_wk, eoe_w, we_w) + do iEdge=edgeSolveStart,edgeSolveEnd +!$acc cache(tend_wk) +!$acc cache(wduz) +!$acc cache(eoe_w) +!$acc cache(we_w) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! horizontal pressure gradient +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = u(k,iEdge) + end do + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wduz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*tend_wk(k)+fzp(k)*tend_wk(k-1)) + end do +!$acc loop vector + do k=3,nVertLevels-1 + wduz(k) = flux3( tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) + end do + +!$acc loop vector shortloop + do j = 1,nEdgesOnEdge(iEdge) + eoe_w(j) = edgesOnEdge(j,iEdge) + we_w(j) = weightsOnEdge(j,iEdge) + end do + +!$acc loop vector + do k=1,nVertLevels + q1 = pv_edge(k,iEdge) + q2 = 0.0 +!$acc loop seq + do j = 1,nEdgesOnEdge(iEdge) + eoe = eoe_w(j) + workpv = 0.5 * (q1 + pv_edge(k,eoe)) + q2 = q2 + we_w(j) * u(k,eoe) * workpv + end do + t_w = - rdzw(k)*(wduz(k+1)-wduz(k)) + tend_u(k,iEdge) = t_w + rho_edge(k,iEdge) * & + (q2 - (ke(k,cell2) - ke(k,cell1)) * & + invDcEdge(iEdge)) - tend_wk(k) * 0.5 * & + (h_divergence(k,cell1)+h_divergence(k,cell2)) + end do + end do +!$acc end parallel + +!$acc parallel vector_length(64) +!$acc loop gang + do iEdge=edgeSolveStart,edgeSolveEnd +!$acc loop vector + do k=1,nVertLevels + tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) + end do + end do +!$acc end parallel + + ! mixing terms are integrated using forward-Euler, so this tendency is only computed in the + ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. + ! + + +!$OMP BARRIER + +! add in mixing for u + + +!----------- rhs for w + + + ! + ! horizontal advection for w + ! +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) +!$acc loop vector + do k=2,nVertLevels + ru_edge_w(k) = fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) + end do + +!$acc loop vector + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop vector + do k=1,nVertLevels + flux_arr(k) = 0.0 + end do + + ! flux_arr stores the value of w at the cell edge used in the + ! horizontal transport + +!$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) +!$acc loop vector + do k=2,nVertLevels + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k)) * coefs_3rd_w(j) + flux_arr(k) = flux_arr(k) + scalar_weight * w(k,iAdvCell) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell)*ru_edge_w(k)*flux_arr(k) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_w(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel + + + + ! + ! horizontal mixing for w - we could combine this with advection directly (i.e. as a turbulent flux), + ! but here we can also code in hyperdiffusion if we wish (2nd order at present) + ! + + +! Note for OpenMP parallelization: We could avoid allocating the delsq_w scratch +! array, and just use the delsq_theta array as was previously done; however, +! particularly when oversubscribing cores with threads, there is the risk that +! some threads may reach code further below that re-uses the delsq_theta array, +! in which case we would need a barrier somewhere between here and that code +! below to ensure correct behavior. + + ! + ! vertical advection, pressure gradient and buoyancy for w + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(tend_wk, wdwz) + do iCell=cellSolveStart,cellSolveEnd + +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = w(k,iCell) + end do + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdwz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + wdwz(k) = 0.25*(rw(k,iCell)+rw(k-1,iCell))*(tend_wk(k)+tend_wk(k-1)) + end do +!$acc loop vector + do k=3,nVertLevels-1 + wdwz(k) = flux3(tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) + end do + +!DIR$ IVDEP +!$acc loop vector + do k=2,nVertLevels + tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) - rdzu(k)*(wdwz(k+1)-wdwz(k)) + end do + end do +!$acc end parallel + +!$acc parallel vector_length(64) +!$acc loop gang worker + do iCell = cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) + end do + end do +!$acc end parallel + + +!----------- rhs for theta + + ! + ! horizontal advection for theta + ! +!$acc parallel vector_length(64) +!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... +!$acc cache(ru_edge_w) +!$acc cache(flux_arr) +!$acc cache(iadv_cell_w) +!$acc cache(coefs_w) +!$acc cache(coefs_3rd_w) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels+1 + tend_wk(k) = 0.0 + end do + +!$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + +!$acc loop vector + do k=1,nVertLevels + ru_edge_w(k) = ru(k,iEdge) + flux_arr(k) = 0.0 + end do + +!$acc loop vector shortloop + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_w(j) = advCellsForEdge(j,iEdge) + coefs_w(j) = adv_coefs(j,iEdge) + coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) + end do + +!$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) +!$acc loop vector + do k=1,nVertLevels + iAdvCell = iadv_cell_w(j) + scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k))*coefs_3rd_w(j) + flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) + end do + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell) * ru_edge_w(k) * flux_arr(k) + end do + + end do + +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_wk(k) + end do + end do +!$acc end parallel +! addition to pick up perturbation flux for rtheta_pp equation + +!$acc parallel vector_length(64) +!$acc loop gang private(flux_arr1,tend_wk, ru_edge_w,ru_save_temp) + do iCell=cellSolveStart,cellSolveEnd +!$acc cache(ru_edge_w) +!$acc cache(flux_arr1) +!$acc cache(ru_save_temp) +!$acc cache(tend_wk) + +!$acc loop vector + do k=1,nVertLevels + tend_wk(k) = tend_theta(k,iCell) + end do + +!$acc loop vector + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!$acc loop vector + do k=1,nVertLevels + ru_edge_w(k) = ru(k,iEdge) + ru_save_temp(k) = ru_save(k,iEdge) + flux_arr1(k) = 0.0 + end do +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + flux_arr1(k) = edgesOnCell_sign(i,iCell)*dvEdge(iEdge)*(ru_save_temp(k)-ru_edge_w(k))*0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) + !flux_arr1(k) = edgesOnCell_sign(i,iCell) *dvEdge(iEdge)*(ru_save(k,iCell)-ru_edge_w(k)) & + ! *0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) + end do +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels +! tend_theta(k,iCell) = tend_theta(k,iCell)-flux_arr1(k) ! division by areaCell picked up down below + tend_wk(k) = tend_wk(k)-flux_arr1(k) + end do + end do +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_wk(k) + end do + + end do +!$acc end parallel + + ! + ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), + ! but here we can also code in hyperdiffusion if we wish (2nd order at present) + ! vertical advection plus diabatic term + ! Note: we are also dividing through by the cell area after the horizontal flux divergence + ! + +!$acc parallel vector_length(64) +!$acc loop gang private(wdtz) + do iCell = cellSolveStart,cellSolveEnd +!$acc cache(wdtz) + +!$acc loop vector shortloop + do k=1,nVertLevels+1,nVertLevels + wdtz(k) = 0. + end do +!$acc loop vector shortloop + do k=2,nVertLevels,nVertLevels-2 + if (k.eq.2) then + wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) + wdtz(k) = wdtz(k)+(rw_save(k,icell)-rw(k,icell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) + else + wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) !rtheta_pp redefinition + end if + end do +!$acc loop vector + do k=3,nVertLevels-1 + wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) + wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell))! rtheta_pp redefinition + end do + +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) + tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme + rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme + tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) + tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) + end do + end do +!$acc end parallel + +!$acc end data + end subroutine atm_compute_dyn_tend_work_rk23 + + + subroutine atm_compute_solve_diagnostics_gpu(dt, state, time_lev, diag, mesh, configs, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + rk_step ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Compute diagnostic fields used in the tendency computations + ! + ! Input: state (s), grid - grid metadata + ! + ! Output: diag - computed diagnostics + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + real (kind=RKIND), intent(in) :: dt + type (mpas_pool_type), intent(inout) :: state + integer, intent(in) :: time_lev ! which time level of state to use + integer, intent(in), optional :: rk_step ! which rk_step + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + + + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree + real (kind=RKIND), dimension(:), pointer :: fVertex, fEdge, invAreaTriangle, invAreaCell + real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, invDvEdge, invDcEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, & + vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, & + divergence + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, & + kiteForCell, verticesOnCell + real (kind=RKIND), dimension(:,:), pointer :: edgesOnVertex_sign, edgesOnCell_sign + integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge + + real (kind=RKIND), pointer :: config_apvm_upwinding + + + call mpas_pool_get_config(configs, 'config_apvm_upwinding', config_apvm_upwinding) + + call mpas_pool_get_array_gpu(state, 'rho_zz', h, time_lev) + call mpas_pool_get_array_gpu(state, 'u', u, time_lev) + + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(diag, 'rho_edge', h_edge) + call mpas_pool_get_array_gpu(diag, 'vorticity', vorticity) + call mpas_pool_get_array_gpu(diag, 'divergence', divergence) + call mpas_pool_get_array_gpu(diag, 'ke', ke) + call mpas_pool_get_array_gpu(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array_gpu(diag, 'pv_vertex', pv_vertex) + call mpas_pool_get_array_gpu(diag, 'pv_cell', pv_cell) + call mpas_pool_get_array_gpu(diag, 'gradPVn', gradPVn) + call mpas_pool_get_array_gpu(diag, 'gradPVt', gradPVt) + + call mpas_pool_get_array_gpu(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array_gpu(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'kiteForCell', kiteForCell) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array_gpu(mesh, 'fVertex', fVertex) + call mpas_pool_get_array_gpu(mesh, 'fEdge', fEdge) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + + call atm_compute_solve_diagnostics_work_gpu(nCells, nEdges, nVertices, & + vertexDegree, dt, config_apvm_upwinding, & + fVertex, fEdge, invAreaTriangle, invAreaCell, dvEdge, dcEdge, invDvEdge, invDcEdge, & + weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, vorticity, ke, pv_edge, pv_vertex, pv_cell, & + gradPVn, gradPVt, divergence, cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, & + edgesOnVertex, kiteForCell, verticesOnCell, edgesOnVertex_sign, edgesOnCell_sign, nEdgesOnCell, nEdgesOnEdge, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + rk_step) + + end subroutine atm_compute_solve_diagnostics_gpu + + + subroutine atm_compute_solve_diagnostics_work_gpu(nCells, nEdges, nVertices, & + vertexDegree, dt, config_apvm_upwinding, & + fVertex, fEdge, invAreaTriangle, invAreaCell, dvEdge, dcEdge, invDvEdge, invDcEdge, & + weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, vorticity, ke, pv_edge, pv_vertex, pv_cell, & + gradPVn, gradPVt, divergence, cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, & + edgesOnVertex, kiteForCell, verticesOnCell, edgesOnVertex_sign, edgesOnCell_sign, nEdgesOnCell, nEdgesOnEdge, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + rk_step) + + use mpas_atm_dimensions + + implicit none + + ! + ! Dummy arguments + ! + integer, intent(in) :: nCells, nEdges, nVertices, vertexDegree + real (kind=RKIND), intent(in) :: dt, config_apvm_upwinding + real (kind=RKIND), dimension(nVertices+1) :: fVertex + real (kind=RKIND), dimension(nEdges+1) :: fEdge + real (kind=RKIND), dimension(nVertices+1) :: invAreaTriangle + real (kind=RKIND), dimension(nCells+1) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1) :: dvEdge + real (kind=RKIND), dimension(nEdges+1) :: dcEdge + real (kind=RKIND), dimension(nEdges+1) :: invDvEdge + real (kind=RKIND), dimension(nEdges+1) :: invDcEdge + real (kind=RKIND), dimension(maxEdges2,nEdges+1) :: weightsOnEdge + real (kind=RKIND), dimension(3,nVertices+1) :: kiteAreasOnVertex + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: h_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: v + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: pv_vertex + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: pv_cell + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: gradPVn + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: gradPVt + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence + integer, dimension(2,nEdges+1) :: cellsOnEdge + integer, dimension(3,nVertices+1) :: cellsOnVertex + integer, dimension(2,nEdges+1) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1) :: edgesOnCell + integer, dimension(maxEdges2,nEdges+1) :: edgesOnEdge + integer, dimension(3,nVertices+1) :: edgesOnVertex + integer, dimension(maxEdges,nCells+1) :: kiteForCell + integer, dimension(maxEdges,nCells+1) :: verticesOnCell + real (kind=RKIND), dimension(3,nVertices+1) :: edgesOnVertex_sign + real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + integer, dimension(nCells+1) :: nEdgesOnCell + integer, dimension(nEdges+1) :: nEdgesOnEdge + + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + + integer, intent(in), optional :: rk_step + + ! + ! Local variables + ! + integer :: iEdge, iCell, iVertex, k, cell1, cell2, eoe, i, j, v1, v2 + real (kind=RKIND) :: h_vertex, r, s + real (kind=RKIND) :: r1, r2, rtemp + + logical, parameter :: hollingsworth=.true. + real (kind=RKIND) :: ke_fact, efac + logical :: reconstruct_v + integer :: temp1,temp2,temp3, gpu_i,gpu_j + + ke_fact = 1.0 - .375 + rtemp = config_apvm_upwinding * dt + +!$acc data present(h_edge, vorticity, divergence, ke, & +!$acc ke_vertex, v, pv_vertex, pv_edge, pv_cell, gradpvn, & +!$acc gradpvt, ke_edge, & +!$acc cellsonedge, dcedge, dvedge, h, u, edgesonvertex, & +!$acc edgesonvertex_sign, invareatriangle, edgesoncell, & +!$acc edgesoncell_sign, invareacell, nedgesoncell, & +!$acc kiteareasonvertex, kiteforcell, verticesoncell, edgesonedge, & +!$acc nedgesonedge, weightsonedge, fvertex, verticesonedge, & +!$acc invdcedge, invdvedge) + + ! + ! Compute height on cell edges at velocity locations + ! +!$acc parallel vector_length(32) +!$acc loop gang + do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + efac = dcEdge(iEdge)*dvEdge(iEdge) + ! efactemp = dcEdge(iEdge) + ! efac = efactemp * efactemp +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2)) + ke_edge(k,iEdge) = efac*u(k,iEdge)**2 + end do + end do +!$acc end parallel + + ! + ! Compute circulation and relative vorticity at each vertex + ! + +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iVertex=vertexStart,vertexEnd +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + vorticity(k,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + s = edgesOnVertex_sign(i,iVertex) * dcEdge(iEdge) + vorticity(k,iVertex) = vorticity(k,iVertex) + s * u(k,iEdge) + end do + vorticity(k,iVertex) = vorticity(k,iVertex) * invAreaTriangle(iVertex) end do end do +!$acc end parallel -!----------- rhs for theta ! - ! horizontal advection for theta + ! Compute the divergence at each cell center ! - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - tend_theta(1:nVertLevels,iCell) = 0.0 +!$acc parallel vector_length(32) +!$acc loop gang + do iCell=cellStart,cellEnd + r = invAreaCell(iCell) +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + divergence(k,iCell) = 0.0 do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) + s = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) + divergence(k,iCell) = divergence(k,iCell) + s * u(k,iEdge) + end do + divergence(k,iCell) = divergence(k,iCell) * r + end do + end do +!$acc end parallel - flux_arr(1:nVertLevels) = 0.0 - - do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) - do k=1,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,ru(k,iEdge))*adv_coefs_3rd(j,iEdge) - flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) - end do - end do +!$OMP BARRIER + ! + ! Compute kinetic energy in each cell (Ringler et al JCP 2009) + ! + ! Replace 2.0 with 2 in exponentiation to avoid outside chance that + ! compiler will actually allow "float raised to float" operation +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iCell=cellStart,cellEnd !DIR$ IVDEP - do k=1,nVertLevels - tend_theta(k,iCell) = tend_theta(k,iCell) - edgesOnCell_sign(i,iCell) * ru(k,iEdge) * flux_arr(k) - end do - +!$acc loop vector + do k=1,nVertLevels + ke(k,iCell) = 0.0 + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + ke(k,iCell) = ke(k,iCell) + 0.25 * ke_edge(k,iEdge) + end do + ke(k,iCell) = ke(k,iCell) * invAreaCell(iCell) end do end do +!$acc end parallel -! addition to pick up perturbation flux for rtheta_pp equation - if(rk_step > 1) then - do iCell=cellSolveStart,cellSolveEnd - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP + if (hollingsworth) then +!$acc parallel vector_length(32) + ! if (hollingsworth) then +!$acc loop gang + do iVertex=vertexStart,vertexEnd + temp1 = EdgesOnVertex(1,iVertex) + temp2 = EdgesOnVertex(2,iVertex) + temp3 = EdgesOnVertex(3,iVertex) + r = 0.25 * invAreaTriangle(iVertex) +!$acc loop vector do k=1,nVertLevels - flux = edgesOnCell_sign(i,iCell)*dvEdge(iEdge)*(ru_save(k,iEdge)-ru(k,iEdge))*0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) - tend_theta(k,iCell) = tend_theta(k,iCell)-flux ! division by areaCell picked up down below + + ke_vertex(k,iVertex) = ( ke_edge(k,temp1)+ke_edge(k,temp2)+ke_edge(k,temp3) )*r end do - end do - end do - end if + end do +!$acc end parallel - ! - ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), - ! but here we can also code in hyperdiffusion if we wish (2nd order at present) - ! +!$OMP BARRIER - if (rk_step == 1) then + ! adjust ke at cell vertices - AG's new KE construction, part 2 + ! - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below +!$acc loop vector + do k=1,nVertLevels + ke(k,iCell) = ke_fact * ke(k,iCell) + end do + end do +!$acc end parallel - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux +!$acc parallel vector_length(32) +!$acc loop gang + do iCell=cellStart,cellEnd +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iVertex = verticesOnCell(i,iCell) + j = kiteForCell(i,iCell) + ke(k,iCell) = ke(k,iCell) + (1.-ke_fact)*kiteAreasOnVertex(j,iVertex) * ke_vertex(k,iVertex) * r end do end do - end do - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + end do +!$acc end parallel + end if - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + ! + ! Compute v (tangential) velocities following Thuburn et al JCP 2009 + ! The tangential velocity is only used to compute the Smagorinsky coefficient - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + reconstruct_v = .true. + if(present(rk_step)) then + if(rk_step /= 3) reconstruct_v = .false. + end if - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do + if (reconstruct_v) then +!$acc parallel vector_length(32) +!$acc loop gang + do iEdge = edgeStart,edgeEnd +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels + v(k,iEdge) = 0.0 + do i=1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) +! temp = temp + weightsOnEdge(i,iEdge) * u(k, eoe) + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe) end do +! v(k,iEdge) = temp + end do + end do +!$acc end parallel + end if - end if ! 4th order mixing is active - - end if ! theta mixing calculated first rk_step ! - ! vertical advection plus diabatic term - ! Note: we are also dividing through by the cell area after the horizontal flux divergence + ! Compute height at vertices, pv at vertices, and average pv to edge locations + ! ( this computes pv_vertex at all vertices bounding real cells ) ! - do iCell = cellSolveStart,cellSolveEnd - - wdtz(1) = 0.0 - - k = 2 - wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) - wdtz(k) = wdtz(k)+(rw_save(k,icell)-rw(k,icell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) - do k=3,nVertLevels-1 - wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) - wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell)) ! rtheta_pp redefinition - end do - k = nVertLevels - wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) ! rtheta_pp redefinition - - wdtz(nVertLevels+1) = 0.0 + ! Avoid dividing h_vertex by areaTriangle and move areaTriangle into + ! numerator for the pv_vertex calculation +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iVertex = vertexStart,vertexEnd !DIR$ IVDEP +!$acc loop vector do k=1,nVertLevels - tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) - tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme - rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme - tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) + pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) end do end do +!$acc end parallel - ! - ! vertical mixing for theta - 2nd order - ! - - if (rk_step == 1) then - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) +!$OMP BARRIER - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + ! + ! Compute pv at the edges + ! ( this computes pv_edge at all edges bounding real cells ) + ! - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do +!$acc parallel num_workers(4) vector_length(32) +!$acc loop gang worker + do iEdge = edgeStart,edgeEnd +!DIR$ IVDEP +!$acc loop vector + do k=1,nVertLevels + pv_edge(k,iEdge) = 0.5 * (pv_vertex(k,verticesOnEdge(1,iEdge)) + pv_vertex(k,verticesOnEdge(2,iEdge))) + end do + end do +!$acc end parallel - else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) + if (config_apvm_upwinding > 0.0) then +!$acc parallel vector_length(32) +!$acc loop gang + do iCell=cellStart,cellEnd +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels + pv_cell(k,iCell) = 0.0 + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iVertex = verticesOnCell(i,iCell) + j = kiteForCell(i,iCell) + pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(j,iVertex) * pv_vertex(k,iVertex) * r + end do + end do + end do +!$acc end parallel - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) +!$OMP BARRIER - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do + ! + ! Modify PV edge with upstream bias. + ! + ! Compute gradient of PV in the tangent direction + ! ( this computes gradPVt at all edges bounding real cells ) + ! + ! Compute gradient of PV in normal direction + ! (tdr: 2009-10-02: this is not correct because the pv_cell in the halo is not correct) + ! + ! Modify PV edge with upstream bias. + ! + ! Merged loops for calculating gradPVt, gradPVn and pv_edge + ! Also precomputed inverses of dvEdge and dcEdge to avoid repeated divisions + ! - end if +!$acc parallel vector_length(32) +!$acc loop gang + do iEdge = edgeStart,edgeEnd + r1 = 1.0_RKIND * invDvEdge(iEdge) + r2 = 1.0_RKIND * invDcEdge(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + v1 = verticesOnEdge(1,iEdge) + v2 = verticesOnEdge(2,iEdge) +!DIR$ IVDEP +!$acc loop vector + do k = 1,nVertLevels - end if + gradPVt(k,iEdge) = (pv_vertex(k,v2) - pv_vertex(k,v1)) * r1 + gradPVn(k,iEdge) = (pv_cell(k,cell2) - pv_cell(k,cell1)) * r2 + pv_edge(k,iEdge) = pv_edge(k,iEdge) - rtemp * (v(k,iEdge) * gradPVt(k,iEdge) + u(k,iEdge) * gradPVn(k,iEdge)) - end if ! compute vertical theta mixing on first rk_step - do iCell = cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k=1,nVertLevels -! tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) - tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) + end do end do - end do +!$acc end parallel + end if ! apvm upwinding +!$acc end data - end subroutine atm_compute_dyn_tend_work + end subroutine atm_compute_solve_diagnostics_work_gpu + subroutine atm_compute_solve_diagnostics(dt, state, time_lev, diag, mesh, configs, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & rk_step ) @@ -5104,42 +6534,42 @@ subroutine atm_compute_solve_diagnostics(dt, state, time_lev, diag, mesh, config call mpas_pool_get_config(configs, 'config_apvm_upwinding', config_apvm_upwinding) - call mpas_pool_get_array(state, 'rho_zz', h, time_lev) - call mpas_pool_get_array(state, 'u', u, time_lev) - - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(diag, 'rho_edge', h_edge) - call mpas_pool_get_array(diag, 'vorticity', vorticity) - call mpas_pool_get_array(diag, 'divergence', divergence) - call mpas_pool_get_array(diag, 'ke', ke) - call mpas_pool_get_array(diag, 'pv_edge', pv_edge) - call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) - call mpas_pool_get_array(diag, 'pv_cell', pv_cell) - call mpas_pool_get_array(diag, 'gradPVn', gradPVn) - call mpas_pool_get_array(diag, 'gradPVt', gradPVt) - - call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) - call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) - call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) - call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) - call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) - call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'kiteForCell', kiteForCell) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) - call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) - call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) - call mpas_pool_get_array(mesh, 'fVertex', fVertex) - call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array_gpu(state, 'rho_zz', h, time_lev) + call mpas_pool_get_array_gpu(state, 'u', u, time_lev) + + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(diag, 'rho_edge', h_edge) + call mpas_pool_get_array_gpu(diag, 'vorticity', vorticity) + call mpas_pool_get_array_gpu(diag, 'divergence', divergence) + call mpas_pool_get_array_gpu(diag, 'ke', ke) + call mpas_pool_get_array_gpu(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array_gpu(diag, 'pv_vertex', pv_vertex) + call mpas_pool_get_array_gpu(diag, 'pv_cell', pv_cell) + call mpas_pool_get_array_gpu(diag, 'gradPVn', gradPVn) + call mpas_pool_get_array_gpu(diag, 'gradPVt', gradPVt) + + call mpas_pool_get_array_gpu(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array_gpu(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array_gpu(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array_gpu(mesh, 'kiteForCell', kiteForCell) + call mpas_pool_get_array_gpu(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array_gpu(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array_gpu(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array_gpu(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array_gpu(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array_gpu(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array_gpu(mesh, 'fVertex', fVertex) + call mpas_pool_get_array_gpu(mesh, 'fEdge', fEdge) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -5519,35 +6949,35 @@ subroutine atm_init_coupled_diagnostics(state, time_lev, diag, mesh, configs, & call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - - call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) - call mpas_pool_get_array(diag, 'theta', theta) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, time_lev) - call mpas_pool_get_array(diag, 'rho', rho) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_base', rho_base) - call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) - call mpas_pool_get_array(diag, 'theta_base', theta_base) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(mesh, 'zz', zz) - call mpas_pool_get_array(state, 'scalars', scalars, time_lev) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(state, 'u', u, time_lev) - call mpas_pool_get_array(state, 'w', w, time_lev) - call mpas_pool_get_array(diag, 'pressure_p', pressure_p) - call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'exner_base', exner_base) - call mpas_pool_get_array(mesh, 'fzm', fzm) - call mpas_pool_get_array(mesh, 'fzp', fzp) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) + call mpas_pool_get_array_gpu(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array_gpu(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array_gpu(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m, time_lev) + call mpas_pool_get_array_gpu(diag, 'theta', theta) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz, time_lev) + call mpas_pool_get_array_gpu(diag, 'rho', rho) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_base', rho_base) + call mpas_pool_get_array_gpu(diag, 'rtheta_base', rtheta_base) + call mpas_pool_get_array_gpu(diag, 'theta_base', theta_base) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(mesh, 'zz', zz) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, time_lev) + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(state, 'u', u, time_lev) + call mpas_pool_get_array_gpu(state, 'w', w, time_lev) + call mpas_pool_get_array_gpu(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array_gpu(diag, 'exner', exner) + call mpas_pool_get_array_gpu(diag, 'exner_base', exner_base) + call mpas_pool_get_array_gpu(mesh, 'fzm', fzm) + call mpas_pool_get_array_gpu(mesh, 'fzp', fzp) + call mpas_pool_get_array_gpu(mesh, 'zb', zb) + call mpas_pool_get_array_gpu(mesh, 'zb3', zb3) + call mpas_pool_get_array_gpu(mesh, 'zb_cell', zb_cell) + call mpas_pool_get_array_gpu(mesh, 'zb3_cell', zb3_cell) rcv = rgas / (cp-rgas) @@ -5653,7 +7083,6 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynami integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - real (kind=RKIND) :: inv_dynamics_split real (kind=RKIND), dimension(:,:), pointer :: ru real (kind=RKIND), dimension(:,:), pointer :: ru_save @@ -5669,63 +7098,181 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynami real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2, rho_zz_old_split real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg, ruAvg_split, wwAvg_split + integer, pointer:: nCells,nEdges,nVertLevels + call mpas_pool_get_array_gpu(diag, 'ru', ru) + call mpas_pool_get_array_gpu(diag, 'ru_save', ru_save) + call mpas_pool_get_array_gpu(diag, 'rw', rw) + call mpas_pool_get_array_gpu(diag, 'rw_save', rw_save) + call mpas_pool_get_array_gpu(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array_gpu(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_p', rho_p) + call mpas_pool_get_array_gpu(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array_gpu(diag, 'rho_zz_old_split', rho_zz_old_split) + call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array_gpu(diag, 'ruAvg_split', ruAvg_split) + call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array_gpu(diag, 'wwAvg_split', wwAvg_split) + + call mpas_pool_get_array_gpu(state, 'u', u_1, 1) + call mpas_pool_get_array_gpu(state, 'u', u_2, 2) + call mpas_pool_get_array_gpu(state, 'w', w_1, 1) + call mpas_pool_get_array_gpu(state, 'w', w_2, 2) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_1, 1) + call mpas_pool_get_array_gpu(state, 'theta_m', theta_m_2, 2) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array_gpu(state, 'rho_zz', rho_zz_2, 2) - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'ruAvg_split', ruAvg_split) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'wwAvg_split', wwAvg_split) - - call mpas_pool_get_array(state, 'u', u_1, 1) - call mpas_pool_get_array(state, 'u', u_2, 2) - call mpas_pool_get_array(state, 'w', w_1, 1) - call mpas_pool_get_array(state, 'w', w_2, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) - call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) + call mpas_pool_get_dimension(state, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - inv_dynamics_split = 1.0_RKIND / real(dynamics_split) - - if (dynamics_substep < dynamics_split) then - ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) - rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) - rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) - rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) + call atm_rk_dynamics_substep_finish_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split,ruAvg,ruAvg_split, wwAvg, wwAvg_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2,dynamics_substep, dynamics_split) + + end subroutine atm_rk_dynamics_substep_finish - u_1(:,edgeStart:edgeEnd) = u_2(:,edgeStart:edgeEnd) - w_1(:,cellStart:cellEnd) = w_2(:,cellStart:cellEnd) - theta_m_1(:,cellStart:cellEnd) = theta_m_2(:,cellStart:cellEnd) - rho_zz_1(:,cellStart:cellEnd) = rho_zz_2(:,cellStart:cellEnd) + subroutine atm_rk_dynamics_substep_finish_work(nVertLevels, nCells, nEdges, & + cellStart, cellEnd, edgeStart, edgeEnd, & + ru, ru_save, rw, rw_save, & + rtheta_p,rtheta_p_save,rho_p,rho_p_save, & + rho_zz_old_split,ruAvg,ruAvg_split, wwAvg, wwAvg_split, & + u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2,dynamics_substep, dynamics_split) - end if + implicit none + integer, intent(in) :: nVertLevels, edgeStart, edgeEnd,cellStart, cellEnd, & + nCells, nEdges + integer, intent(in) :: dynamics_substep, dynamics_split + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw, rw_save + real (kind=RKIND), dimension(nVertLevels,nEdges+1):: ru, ru_save, u_1, u_2 + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ruAvg, ruAvg_split + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: wwAvg,wwAvg_split, & + w_1,w_2 + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_p, rho_p_save, & + rtheta_p,rtheta_p_save, & + rho_zz_old_split, & + rho_zz_1, rho_zz_2, & + theta_m_1, theta_m_2 + real (kind=RKIND) :: inv_dynamics_split + integer:: i,j + inv_dynamics_split = 1.0_RKIND / real(dynamics_split) +!$acc data present(ru, ru_save, rw, rw_save, & +!$acc rtheta_p,rtheta_p_save,rho_p,rho_p_save, & +!$acc rho_zz_old_split,ruAvg,ruAvg_split, wwAvg, wwAvg_split, & +!$acc u_1,u_2,w_1,w_2,theta_m_1,theta_m_2,rho_zz_1,rho_zz_2) + if (dynamics_substep < dynamics_split) then +!$acc parallel vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels + rho_p_save(j,i) = rho_p(j,i) + theta_m_1(j,i) = theta_m_2(j,i) + rtheta_p_save(j,i) = rtheta_p(j,i) + rho_zz_1(j,i) = rho_zz_2(j,i) + enddo +!$acc loop vector + do j=1,nVertLevels+1 + rw_save(j,i) = rw(j,i) + w_1(j,i) = w_2(j,i) + enddo + enddo +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ru_save(j,i) = ru(j,i) + u_1(j,i) = u_2(j,i) + enddo + enddo +!$acc end parallel + +! ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) +! rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) +! rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) +! rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) + +! u_1(:,edgeStart:edgeEnd) = u_2(:,edgeStart:edgeEnd) +! w_1(:,cellStart:cellEnd) = w_2(:,cellStart:cellEnd) +! theta_m_1(:,cellStart:cellEnd) = theta_m_2(:,cellStart:cellEnd) +! rho_zz_1(:,cellStart:cellEnd) = rho_zz_2(:,cellStart:cellEnd) + end if if (dynamics_substep == 1) then - ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd) - wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd) + +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels+1 + wwAvg_split(j,i) = wwAvg(j,i) + enddo + enddo + +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ruAvg_split(j,i) = ruAvg(j,i) + enddo + enddo +!$acc end parallel else - ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd)+ruAvg_split(:,edgeStart:edgeEnd) - wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd)+wwAvg_split(:,cellStart:cellEnd) + +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels+1 + wwAvg_split(j,i) = wwAvg(j,i)+wwAvg_split(j,i) + enddo + enddo + +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ruAvg_split(j,i) = ruAvg(j,i)+ruAvg_split(j,i) + enddo + enddo +!$acc end parallel + end if + if (dynamics_substep == dynamics_split) then - ruAvg(:,edgeStart:edgeEnd) = ruAvg_split(:,edgeStart:edgeEnd) * inv_dynamics_split - wwAvg(:,cellStart:cellEnd) = wwAvg_split(:,cellStart:cellEnd) * inv_dynamics_split - rho_zz_1(:,cellStart:cellEnd) = rho_zz_old_split(:,cellStart:cellEnd) +!$acc parallel num_gangs(256) vector_length(32) +!$acc loop gang + do i = cellStart,cellEnd +!$acc loop vector + do j=1,nVertLevels+1 + wwAvg(j,i) = wwAvg_split(j,i) * inv_dynamics_split + enddo + do j=1,nVertLevels + rho_zz_1(j,i) = rho_zz_old_split(j,i) + enddo + enddo + +!$acc loop gang + do i = edgeStart,edgeEnd +!$acc loop vector + do j=1,nVertLevels + ruAvg(j,i) = ruAvg_split(j,i) * inv_dynamics_split + enddo + enddo +!$acc end parallel +!$acc update host(u_2,w_2) end if - end subroutine atm_rk_dynamics_substep_finish + +!$acc end data + end subroutine atm_rk_dynamics_substep_finish_work subroutine summarize_timestep(domain) use ieee_arithmetic, only : ieee_is_nan @@ -5735,7 +7282,7 @@ subroutine summarize_timestep(domain) type (domain_type), intent(inout) :: domain real (kind=RKIND), parameter :: pi_const = 2.0_RKIND*asin(1.0_RKIND) - + logical, pointer :: config_print_global_minmax_vel logical, pointer :: config_print_detailed_minmax_vel logical, pointer :: config_print_global_minmax_sca @@ -5773,7 +7320,7 @@ subroutine summarize_timestep(domain) call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) if (config_print_detailed_minmax_vel) then - call mpas_log_write('') + write(0,*) ' ' block => domain % blocklist do while (associated(block)) @@ -5781,18 +7328,18 @@ subroutine summarize_timestep(domain) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(mesh, 'indexToCellID', indexToCellID) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'lonCell', lonCell) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) - call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + call mpas_pool_get_array_gpu(state, 'u', u, 2) + call mpas_pool_get_array_gpu(diag, 'v', v) + call mpas_pool_get_array_gpu(mesh, 'indexToCellID', indexToCellID) + call mpas_pool_get_array_gpu(mesh, 'latCell', latCell) + call mpas_pool_get_array_gpu(mesh, 'lonCell', lonCell) + call mpas_pool_get_array_gpu(mesh, 'latEdge', latEdge) + call mpas_pool_get_array_gpu(mesh, 'lonEdge', lonEdge) call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - +!!$acc update host(w,u) scalar_min = 1.0e20 indexMax = -1 kMax = -1 @@ -5825,9 +7372,8 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global min w: ', global_scalar_min, & + ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' scalar_max = -1.0e20 indexMax = -1 @@ -5861,9 +7407,8 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global max w: ', global_scalar_max, & + ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' scalar_min = 1.0e20 indexMax = -1 @@ -5897,9 +7442,8 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global min u: ', global_scalar_min, & + ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' scalar_max = -1.0e20 indexMax = -1 @@ -5933,9 +7477,8 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global max u: ', global_scalar_max, & + ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' scalar_max = -1.0e20 indexMax = -1 @@ -5970,9 +7513,8 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global max wsp: ', global_scalar_max, & + ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' ! ! Check for NaNs @@ -5980,7 +7522,7 @@ subroutine summarize_timestep(domain) do iCell = 1, nCellsSolve do k = 1, nVertLevels if (ieee_is_nan(w(k,iCell))) then - call mpas_log_write('NaN detected in ''w'' field.', messageType=MPAS_LOG_CRIT) + call mpas_dmpar_global_abort('NaN detected in ''w'' field.') end if end do end do @@ -5988,7 +7530,7 @@ subroutine summarize_timestep(domain) do iEdge = 1, nEdgesSolve do k = 1, nVertLevels if (ieee_is_nan(u(k,iEdge))) then - call mpas_log_write('NaN detected in ''u'' field.', messageType=MPAS_LOG_CRIT) + call mpas_dmpar_global_abort('NaN detected in ''u'' field.') end if end do end do @@ -5997,14 +7539,14 @@ subroutine summarize_timestep(domain) end do else if (config_print_global_minmax_vel) then - call mpas_log_write('') + write(0,*) ' ' block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array_gpu(state, 'w', w, 2) + call mpas_pool_get_array_gpu(state, 'u', u, 2) call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) @@ -6019,7 +7561,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max w $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + write(0,*) 'global min, max w ', global_scalar_min, global_scalar_max scalar_min = 0.0 scalar_max = 0.0 @@ -6031,22 +7573,20 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max u $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + write(0,*) 'global min, max u ', global_scalar_min, global_scalar_max block => block % next end do end if if (config_print_global_minmax_sca) then - if (.not. (config_print_global_minmax_vel .or. config_print_detailed_minmax_vel)) then - call mpas_log_write('') - end if + if (.not. (config_print_global_minmax_vel .or. config_print_detailed_minmax_vel)) write(0,*) ' ' block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array_gpu(state, 'scalars', scalars, 2) call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) @@ -6062,7 +7602,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write(' global min, max scalar $i $r $r', intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) + write(0,'(a,i4,2(1x,e17.10))') ' global min, max scalar ', iScalar, global_scalar_min, global_scalar_max end do block => block % next diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 6d99e56be..4f9c55095 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -20,9 +20,10 @@ module mpas_pool_routines use mpas_kind_types use mpas_derived_types + use mpas_io_units use mpas_field_routines use mpas_threading - use mpas_log + use mpas_abort, only : mpas_dmpar_global_abort interface mpas_pool_add_field module procedure mpas_pool_add_field_0d_real @@ -81,6 +82,21 @@ module mpas_pool_routines module procedure mpas_pool_get_array_1d_char end interface + interface mpas_pool_get_array_gpu + module procedure mpas_pool_get_array_0d_real_gpu + module procedure mpas_pool_get_array_1d_real_gpu + module procedure mpas_pool_get_array_2d_real_gpu + module procedure mpas_pool_get_array_3d_real_gpu + module procedure mpas_pool_get_array_4d_real_gpu + module procedure mpas_pool_get_array_5d_real_gpu + module procedure mpas_pool_get_array_0d_int_gpu + module procedure mpas_pool_get_array_1d_int_gpu + module procedure mpas_pool_get_array_2d_int_gpu + module procedure mpas_pool_get_array_3d_int_gpu + module procedure mpas_pool_get_array_0d_char_gpu + module procedure mpas_pool_get_array_1d_char_gpu + end interface + interface mpas_pool_add_config module procedure mpas_pool_add_config_real module procedure mpas_pool_add_config_int @@ -4238,6 +4254,25 @@ subroutine mpas_pool_get_array_0d_real(inPool, key, scalar, timeLevel)!{{{ end subroutine mpas_pool_get_array_0d_real!}}} + subroutine mpas_pool_get_array_0d_real_gpu(inPool, key, scalar, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), pointer :: scalar + integer, intent(in), optional :: timeLevel + + type (field0DReal), pointer :: field + + + call mpas_pool_get_field_0d_real(inPool, key, field, timeLevel) + + nullify(scalar) + if (associated(field)) scalar => field % scalar + !$acc enter data copyin(field%scalar) + end subroutine mpas_pool_get_array_0d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_1d_real @@ -4268,6 +4303,25 @@ subroutine mpas_pool_get_array_1d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_1d_real!}}} + subroutine mpas_pool_get_array_1d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DReal), pointer :: field + + + call mpas_pool_get_field_1d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + end subroutine mpas_pool_get_array_1d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_2d_real @@ -4298,6 +4352,26 @@ subroutine mpas_pool_get_array_2d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_2d_real!}}} + subroutine mpas_pool_get_array_2d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field2DReal), pointer :: field + + + call mpas_pool_get_field_2d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_2d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_3d_real @@ -4329,6 +4403,26 @@ subroutine mpas_pool_get_array_3d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_3d_real!}}} + subroutine mpas_pool_get_array_3d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field3DReal), pointer :: field + + + call mpas_pool_get_field_3d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_3d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_4d_real ! @@ -4358,6 +4452,26 @@ subroutine mpas_pool_get_array_4d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_4d_real!}}} + subroutine mpas_pool_get_array_4d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field4DReal), pointer :: field + + + call mpas_pool_get_field_4d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_4d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_5d_real @@ -4388,6 +4502,26 @@ subroutine mpas_pool_get_array_5d_real(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_5d_real!}}} + subroutine mpas_pool_get_array_5d_real_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field5DReal), pointer :: field + + + call mpas_pool_get_field_5d_real(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_5d_real_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_0d_int @@ -4418,6 +4552,26 @@ subroutine mpas_pool_get_array_0d_int(inPool, key, scalar, timeLevel)!{{{ end subroutine mpas_pool_get_array_0d_int!}}} + subroutine mpas_pool_get_array_0d_int_gpu(inPool, key, scalar, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, pointer :: scalar + integer, intent(in), optional :: timeLevel + + type (field0DInteger), pointer :: field + + + call mpas_pool_get_field_0d_int(inPool, key, field, timeLevel) + + nullify(scalar) + if (associated(field)) scalar => field % scalar + !$acc enter data copyin(field%scalar) + + end subroutine mpas_pool_get_array_0d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_1d_int @@ -4448,6 +4602,26 @@ subroutine mpas_pool_get_array_1d_int(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_1d_int!}}} + subroutine mpas_pool_get_array_1d_int_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DInteger), pointer :: field + + + call mpas_pool_get_field_1d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_1d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_2d_int @@ -4478,6 +4652,26 @@ subroutine mpas_pool_get_array_2d_int(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_2d_int!}}} + subroutine mpas_pool_get_array_2d_int_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field2DInteger), pointer :: field + + + call mpas_pool_get_field_2d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_2d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_3d_int @@ -4508,6 +4702,26 @@ subroutine mpas_pool_get_array_3d_int(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_3d_int!}}} + subroutine mpas_pool_get_array_3d_int_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + integer, dimension(:,:,:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field3DInteger), pointer :: field + + + call mpas_pool_get_field_3d_int(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_3d_int_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_0d_char @@ -4538,6 +4752,26 @@ subroutine mpas_pool_get_array_0d_char(inPool, key, string, timeLevel)!{{{ end subroutine mpas_pool_get_array_0d_char!}}} + subroutine mpas_pool_get_array_0d_char_gpu(inPool, key, string, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), pointer :: string + integer, intent(in), optional :: timeLevel + + type (field0DChar), pointer :: field + + + call mpas_pool_get_field_0d_char(inPool, key, field, timeLevel) + + nullify(string) + if (associated(field)) string => field % scalar + !$acc enter data copyin(field%scalar) + + end subroutine mpas_pool_get_array_0d_char_gpu!}}} + !----------------------------------------------------------------------- ! subroutine mpas_pool_get_array_1d_char @@ -4568,6 +4802,26 @@ subroutine mpas_pool_get_array_1d_char(inPool, key, array, timeLevel)!{{{ end subroutine mpas_pool_get_array_1d_char!}}} + subroutine mpas_pool_get_array_1d_char_gpu(inPool, key, array, timeLevel)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: inPool + character (len=*), intent(in) :: key + character (len=StrKIND), dimension(:), pointer :: array + integer, intent(in), optional :: timeLevel + + type (field1DChar), pointer :: field + + + call mpas_pool_get_field_1d_char(inPool, key, field, timeLevel) + + nullify(array) + if (associated(field)) array => field % array + !$acc enter data copyin(field%array) + + end subroutine mpas_pool_get_array_1d_char_gpu!}}} + !----------------------------------------------------------------------- ! routine mpas_pool_add_config_real @@ -5643,48 +5897,48 @@ recursive subroutine mpas_pool_print_summary(inPool, memberType, recurseSubpools if ( poolItr % memberType == memberType .and. memberType == MPAS_POOL_CONFIG ) then if ( poolItr % dataType == MPAS_POOL_REAL ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempReal) - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $r', realArgs=(/tempReal/)) + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = ', tempReal else if ( poolItr % dataType == MPAS_POOL_INTEGER ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempInteger) - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempInteger/)) + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = ', tempInteger else if ( poolItr % dataType == MPAS_POOL_LOGICAL ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempLogical) if ( tempLogical ) then - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .true.') + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .true.' else - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .false.') + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .false.' end if else if ( poolItr % dataType == MPAS_POOL_CHARACTER ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempChar) - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = ''' // trim(tempChar) // '''') + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = ''' // trim(tempChar) // '''' end if ! Handle packages else if (poolItr % memberType == memberType .and. memberType == MPAS_POOL_PACKAGE ) then call mpas_pool_get_package(inPool, poolItr % memberName, tempLogical) if ( tempLogical ) then - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .true.') + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .true.' else - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .false.') + write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .false.' end if ! Handle fields else if (poolItr % memberType == memberType .and. memberType == MPAS_POOL_FIELD ) then - call mpas_log_write(' ' // trim(poolItr % memberName)) + write(stderrUnit, *) ' ' // trim(poolItr % memberName) if ( poolItr % dataType == MPAS_POOL_REAL) then - call mpas_log_write(' Type: Real') + write(stderrUnit, *) ' Type: Real' else if ( poolItr % dataType == MPAS_POOL_INTEGER) then - call mpas_log_write(' Type: Integer') + write(stderrUnit, *) ' Type: Integer' else if ( poolItr % dataType == MPAS_POOL_CHARACTER) then - call mpas_log_write(' Type: Character') + write(stderrUnit, *) ' Type: Character' else if ( poolItr % dataType == MPAS_POOL_LOGICAL) then - call mpas_log_write(' Type: Logical') + write(stderrUnit, *) ' Type: Logical' end if - call mpas_log_write(' Number of dimensions: $i', intArgs=(/poolItr % nDims/)) - call mpas_log_write(' Number of time levels: $i', intArgs=(/poolItr % nTimeLevels/)) + write(stderrUnit, *) ' Number of dimensions: ', poolItr % nDims + write(stderrUnit, *) ' Number of time levels: ', poolItr % nTimeLevels else if (poolItr % memberType == MPAS_POOL_SUBPOOL .and. recurseSubpools ) then - call mpas_log_write(' ** Begin subpool: ' // trim(poolItr % memberName)) + write(stderrUnit, *) ' ** Begin subpool: ' // trim(poolItr % memberName) call mpas_pool_get_subpool(inPool, poolItr % memberName, subPool) call mpas_pool_print_summary(subPool, memberType, recurseSubpools) - call mpas_log_write(' ** End subpool: ' // trim(poolItr % memberName)) + write(stderrUnit, *) ' ** End subpool: ' // trim(poolItr % memberName) end if end do @@ -5889,12 +6143,13 @@ subroutine pool_mesg(mesg)!{{{ if (currentErrorLevel == MPAS_POOL_WARN) then if ( threadNum == 0 ) then - call mpas_log_write(trim(mesg), MPAS_LOG_WARN) + write(stderrUnit,*) trim(mesg) end if else if (currentErrorLevel == MPAS_POOL_FATAL) then if ( threadNum == 0 ) then - call mpas_log_write(trim(mesg), MPAS_LOG_CRIT) + write(stderrUnit,*) trim(mesg) end if + call mpas_dmpar_global_abort(trim(mesg)) end if end subroutine pool_mesg!}}} @@ -5918,11 +6173,11 @@ subroutine pool_print_table_size(pool)!{{{ head_size = head_size + 1 ptr => ptr % next end do - call mpas_log_write('List $i : $i', intArgs=(/i, head_size/) ) + write(stderrUnit,*) 'List ', i, ' : ', head_size total_size = total_size + head_size end do - call mpas_log_write('----------------') - call mpas_log_write('Total: $i', intArgs=(/total_size/)) + write(stderrUnit,*) '----------------' + write(stderrUnit,*) 'Total: ', total_size end subroutine pool_print_table_size!}}} @@ -5943,35 +6198,34 @@ recursive subroutine pool_print_members(pool)!{{{ logical, pointer :: logPtr character (len=StrKIND) :: charPtr - call mpas_log_write(' Constants: ') - call mpas_log_write(' Real: $i', intArgs=(/MPAS_POOL_REAL/)) - call mpas_log_write(' Integer: $i', intArgs=(/MPAS_POOL_INTEGER/)) - call mpas_log_write(' Logical: $i', intArgs=(/MPAS_POOL_LOGICAL/)) - call mpas_log_write(' Character: $i', intArgs=(/MPAS_POOL_CHARACTER/)) + write(stderrUnit, *) ' Constants: ' + write(stderrUnit, *) ' Real: ', MPAS_POOL_REAL + write(stderrUnit, *) ' Integer: ', MPAS_POOL_INTEGER + write(stderrUnit, *) ' Logical: ', MPAS_POOL_LOGICAL + write(stderrUnit, *) ' Character: ', MPAS_POOL_CHARACTER -! call mpas_log_write('Pool Size:') +! write(stderrUnit, *) 'Pool Size:' ! call pool_print_table_size(pool) call mpas_pool_begin_iteration(pool) do while(mpas_pool_get_next_member(pool, poolItr)) if (poolItr % memberType == MPAS_POOL_SUBPOOL) then - call mpas_log_write('** Found subpool named: ' // trim(poolItr % memberName)) + write(stderrUnit, *) '** Found subpool named: ', trim(poolItr % memberName) call mpas_pool_get_subpool(pool, trim(poolItr % memberName), subpool) call pool_print_members(subpool) else if (poolItr % memberType == MPAS_POOL_CONFIG) then - call mpas_log_write(' Config Option: ' // trim(poolItr % memberName) // ' $i', intArgs=(/ poolItr % dataType/)) + write(stderrUnit, *) ' Config Option: ', trim(poolItr % memberName), poolItr % dataType else if (poolItr % memberType == MPAS_POOL_DIMENSION) then - call mpas_log_write(' Dimension: ' // trim(poolItr % memberName) // ' $i $i', intArgs=(/poolItr % dataType, poolItr % nDims/)) + write(stderrUnit, *) ' Dimension: ', trim(poolItr % memberName), poolItr % dataType, poolItr % nDims else if (poolItr % memberType == MPAS_POOL_PACKAGE) then - call mpas_log_write(' Package: ' // trim(poolItr % memberName)) + write(stderrUnit, *) ' Package: ', trim(poolItr % memberName) else if (poolItr % memberType == MPAS_POOL_FIELD) then - call mpas_log_write(' Field: ' // trim(poolItr % memberName) // ' $i $i $i', & - intArgs=(/poolItr % dataType, poolItr % nDims, poolItr % nTimeLevels/)) + write(stderrUnit, *) ' Field: ', trim(poolItr % memberName), poolItr % dataType, poolItr % nDims, poolItr % nTimeLevels end if end do - call mpas_log_write('Done with pool') - call mpas_log_write('') + write(stderrUnit, *) 'Done with pool' + write(stderrUnit, *) '' end subroutine pool_print_members!}}} From b950f2a2f01a46423c55980fc7ec724353c11447 Mon Sep 17 00:00:00 2001 From: raghuraj19 Date: Mon, 5 Jun 2017 13:47:06 -0700 Subject: [PATCH 23/28] Upgrading to MPAS 5.1 without bugs --- .../dynamics/mpas_atm_time_integration.F | 69 ++++++++++-------- src/framework/mpas_pool_routines.F | 73 +++++++++---------- 2 files changed, 74 insertions(+), 68 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 081c599ac..8e68448f9 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -99,8 +99,8 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) if (trim(config_time_integration) == 'SRK3') then call atm_srk3(domain, dt, itimestep) else - call mpas_dmpar_global_abort('Unknown time integration option '//trim(config_time_integration), deferredAbort=.true.) - call mpas_dmpar_global_abort('Currently, only ''SRK3'' is supported.') + call mpas_log_write('Unknown time integration option'//trim(config_time_integration), messageType=MPAS_LOG_ERR) + call mpas_log_write('Currently, only ''SRK3'' is supported.',messageType=MPAS_LOG_CRIT) end if call mpas_set_time(currTime, dateTimeString=timeStamp) @@ -277,13 +277,13 @@ subroutine atm_srk3(domain, dt, itimestep) dynamics_split = config_dynamics_split if (config_split_dynamics_transport) then dt_dynamics = dt/real(dynamics_split) - write(0,*) ' split dynamics-transport integration ',dynamics_split + call mpas_log_write(' split dynamics-transport integration $i',intArgs=(/dynamics_split/)) else dynamics_split = 1 dt_dynamics = dt - write(0,*) ' coupled RK3 dynamics-transport integration ' + call mpas_log_write(' coupled RK3 dynamics-transport integration ') end if - if (.not. config_scalar_advection ) write(0,*) ' scalar advection turned off ' + if (.not. config_scalar_advection ) call mpas_log_write(' scalar advection turned off ') number_of_sub_steps = config_number_of_sub_steps @@ -3056,7 +3056,7 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm if (local_advance_density) then if ((.not.present(scalar_tend)) .or. (.not.present(rho_zz_int))) then - call mpas_dmpar_global_abort('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.') + call mpas_log_write('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.',messageType=MPAS_LOG_CRIT) end if do iCell=cellSolveStart,cellSolveEnd @@ -3667,7 +3667,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve if (local_advance_density) then if (.not.present(rho_zz_int)) then - call mpas_dmpar_global_abort('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.') + call mpas_log_write('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.',messageType=MPAS_LOG_CRIT) end if ! begin with update of density @@ -3718,7 +3718,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_old(k,iCell)) end do end do - write(0,*) ' scmin, scmin old in ',scmin,scmax + call mpas_log_write(' scmin, scmin old in $r $r',realArgs=(/scmin,scmax/)) scmin = scalar_new(1,1) scmax = scalar_new(1,1) @@ -3728,7 +3728,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_new(k,iCell)) end do end do - write(0,*) ' scmin, scmin new in ',scmin,scmax + call mpas_log_write(' scmin, scmin new in ', realArgs=(/scmin,scmax/)) #endif @@ -4068,15 +4068,15 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scmax = max(scmax,scalar_new(k,iCell)) scmin = min(scmin,scalar_new(k,iCell)) if (s_max(k,iCell) < scalar_new(k,iCell)) then - write(32,*) ' over - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell) + call mpas_log_write(' over - k,iCell,s_min,s_max,scalar_new ',intArgs=(/k,iCell/),realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) end if if (s_min(k,iCell) > scalar_new(k,iCell)) then - write(32,*) ' under - k,iCell,s_min,s_max,scalar_new ',k,iCell,s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell) + call mpas_log_write(' under - k,iCell,s_min,s_max,scalar_new ',intArgs=(/k,iCell/),realArgs=(/s_min(k,iCell),s_max(k,iCell),scalar_new(k,iCell)/)) end if end do end do - write(0,*) ' scmin, scmax new out ',scmin,scmax - write(0,*) ' icell_min, k_min ',icellmax, kmax + call mpas_log_write(' scmin, scmax new out $r $r',realArgs=(/scmin,scmax/)) + call mpas_log_write(' icell_min, k_min ', intArgs=(/icellmax, kmax/)) #endif ! the update should be positive definite. but roundoff can sometimes leave small negative values @@ -7320,7 +7320,7 @@ subroutine summarize_timestep(domain) call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) if (config_print_detailed_minmax_vel) then - write(0,*) ' ' + call mpas_log_write('') block => domain % blocklist do while (associated(block)) @@ -7372,8 +7372,9 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global min w: ', global_scalar_min, & - ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global,lonMax_global/)) scalar_max = -1.0e20 indexMax = -1 @@ -7407,8 +7408,9 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global max w: ', global_scalar_max, & - ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global,lonMax_global/)) scalar_min = 1.0e20 indexMax = -1 @@ -7442,8 +7444,9 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global min u: ', global_scalar_min, & - ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global,lonMax_global/)) scalar_max = -1.0e20 indexMax = -1 @@ -7477,8 +7480,9 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global max u: ', global_scalar_max, & - ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global,lonMax_global/)) scalar_max = -1.0e20 indexMax = -1 @@ -7513,8 +7517,9 @@ subroutine summarize_timestep(domain) if (lonMax_global > 180.0) then lonMax_global = lonMax_global - 360.0 end if - write(0,'(a,f9.4,a,i4,a,f7.3,a,f8.3,a)') ' global max wsp: ', global_scalar_max, & - ' k=', kMax_global, ', ', latMax_global, ' lat ', lonMax_global, ' lon' + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon',intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global,lonMax_global/)) ! ! Check for NaNs @@ -7522,7 +7527,7 @@ subroutine summarize_timestep(domain) do iCell = 1, nCellsSolve do k = 1, nVertLevels if (ieee_is_nan(w(k,iCell))) then - call mpas_dmpar_global_abort('NaN detected in ''w'' field.') + call mpas_log_write('NaN detected in ''w'' field.',messageType=MPAS_LOG_CRIT) end if end do end do @@ -7530,7 +7535,7 @@ subroutine summarize_timestep(domain) do iEdge = 1, nEdgesSolve do k = 1, nVertLevels if (ieee_is_nan(u(k,iEdge))) then - call mpas_dmpar_global_abort('NaN detected in ''u'' field.') + call mpas_log_write('NaN detected in ''u''field.',messageType=MPAS_LOG_CRIT) end if end do end do @@ -7539,7 +7544,7 @@ subroutine summarize_timestep(domain) end do else if (config_print_global_minmax_vel) then - write(0,*) ' ' + call mpas_log_write('') block => domain % blocklist do while (associated(block)) @@ -7561,7 +7566,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - write(0,*) 'global min, max w ', global_scalar_min, global_scalar_max + call mpas_log_write('global min, max w $r $r',realArgs=(/global_scalar_min, global_scalar_max/)) scalar_min = 0.0 scalar_max = 0.0 @@ -7573,14 +7578,16 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - write(0,*) 'global min, max u ', global_scalar_min, global_scalar_max + call mpas_log_write('global min, max u $r $r',realArgs=(/global_scalar_min, global_scalar_max/)) block => block % next end do end if if (config_print_global_minmax_sca) then - if (.not. (config_print_global_minmax_vel .or. config_print_detailed_minmax_vel)) write(0,*) ' ' + if (.not. (config_print_global_minmax_vel .or. config_print_detailed_minmax_vel)) then + call mpas_log_write('') + end if block => domain % blocklist do while (associated(block)) @@ -7602,7 +7609,7 @@ subroutine summarize_timestep(domain) end do call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - write(0,'(a,i4,2(1x,e17.10))') ' global min, max scalar ', iScalar, global_scalar_min, global_scalar_max + call mpas_log_write(' global min, max scalar $i $r $r',intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) end do block => block % next diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 4f9c55095..9d78a9a75 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -20,10 +20,9 @@ module mpas_pool_routines use mpas_kind_types use mpas_derived_types - use mpas_io_units use mpas_field_routines use mpas_threading - use mpas_abort, only : mpas_dmpar_global_abort + use mpas_log interface mpas_pool_add_field module procedure mpas_pool_add_field_0d_real @@ -5897,48 +5896,48 @@ recursive subroutine mpas_pool_print_summary(inPool, memberType, recurseSubpools if ( poolItr % memberType == memberType .and. memberType == MPAS_POOL_CONFIG ) then if ( poolItr % dataType == MPAS_POOL_REAL ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempReal) - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = ', tempReal + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $r', realArgs=(/tempReal/)) else if ( poolItr % dataType == MPAS_POOL_INTEGER ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempInteger) - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = ', tempInteger + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempInteger/)) else if ( poolItr % dataType == MPAS_POOL_LOGICAL ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempLogical) if ( tempLogical ) then - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .true.' + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .true.') else - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .false.' + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .false.') end if else if ( poolItr % dataType == MPAS_POOL_CHARACTER ) then call mpas_pool_get_config(inPool, poolItr % memberName, tempChar) - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = ''' // trim(tempChar) // '''' + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = ''' // trim(tempChar) // '''') end if ! Handle packages else if (poolItr % memberType == memberType .and. memberType == MPAS_POOL_PACKAGE ) then call mpas_pool_get_package(inPool, poolItr % memberName, tempLogical) if ( tempLogical ) then - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .true.' + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .true.') else - write(stderrUnit, *) ' ' // trim(poolItr % memberName) // ' = .false.' + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = .false.') end if ! Handle fields else if (poolItr % memberType == memberType .and. memberType == MPAS_POOL_FIELD ) then - write(stderrUnit, *) ' ' // trim(poolItr % memberName) + call mpas_log_write(' ' // trim(poolItr % memberName)) if ( poolItr % dataType == MPAS_POOL_REAL) then - write(stderrUnit, *) ' Type: Real' + call mpas_log_write(' Type: Real') else if ( poolItr % dataType == MPAS_POOL_INTEGER) then - write(stderrUnit, *) ' Type: Integer' + call mpas_log_write(' Type: Integer') else if ( poolItr % dataType == MPAS_POOL_CHARACTER) then - write(stderrUnit, *) ' Type: Character' + call mpas_log_write(' Type: Character') else if ( poolItr % dataType == MPAS_POOL_LOGICAL) then - write(stderrUnit, *) ' Type: Logical' + call mpas_log_write(' Type: Logical') end if - write(stderrUnit, *) ' Number of dimensions: ', poolItr % nDims - write(stderrUnit, *) ' Number of time levels: ', poolItr % nTimeLevels + call mpas_log_write(' Number of dimensions: $i', intArgs=(/poolItr % nDims/)) + call mpas_log_write(' Number of time levels: $i', intArgs=(/poolItr % nTimeLevels/)) else if (poolItr % memberType == MPAS_POOL_SUBPOOL .and. recurseSubpools ) then - write(stderrUnit, *) ' ** Begin subpool: ' // trim(poolItr % memberName) + call mpas_log_write(' ** Begin subpool: ' // trim(poolItr % memberName)) call mpas_pool_get_subpool(inPool, poolItr % memberName, subPool) call mpas_pool_print_summary(subPool, memberType, recurseSubpools) - write(stderrUnit, *) ' ** End subpool: ' // trim(poolItr % memberName) + call mpas_log_write(' ** End subpool: ' // trim(poolItr % memberName)) end if end do @@ -6143,13 +6142,12 @@ subroutine pool_mesg(mesg)!{{{ if (currentErrorLevel == MPAS_POOL_WARN) then if ( threadNum == 0 ) then - write(stderrUnit,*) trim(mesg) + call mpas_log_write(trim(mesg), MPAS_LOG_WARN) end if else if (currentErrorLevel == MPAS_POOL_FATAL) then if ( threadNum == 0 ) then - write(stderrUnit,*) trim(mesg) + call mpas_log_write(trim(mesg), MPAS_LOG_CRIT) end if - call mpas_dmpar_global_abort(trim(mesg)) end if end subroutine pool_mesg!}}} @@ -6173,11 +6171,11 @@ subroutine pool_print_table_size(pool)!{{{ head_size = head_size + 1 ptr => ptr % next end do - write(stderrUnit,*) 'List ', i, ' : ', head_size + call mpas_log_write('List $i : $i', intArgs=(/i, head_size/) ) total_size = total_size + head_size end do - write(stderrUnit,*) '----------------' - write(stderrUnit,*) 'Total: ', total_size + call mpas_log_write('----------------') + call mpas_log_write('Total: $i', intArgs=(/total_size/)) end subroutine pool_print_table_size!}}} @@ -6198,34 +6196,35 @@ recursive subroutine pool_print_members(pool)!{{{ logical, pointer :: logPtr character (len=StrKIND) :: charPtr - write(stderrUnit, *) ' Constants: ' - write(stderrUnit, *) ' Real: ', MPAS_POOL_REAL - write(stderrUnit, *) ' Integer: ', MPAS_POOL_INTEGER - write(stderrUnit, *) ' Logical: ', MPAS_POOL_LOGICAL - write(stderrUnit, *) ' Character: ', MPAS_POOL_CHARACTER + call mpas_log_write(' Constants: ') + call mpas_log_write(' Real: $i', intArgs=(/MPAS_POOL_REAL/)) + call mpas_log_write(' Integer: $i', intArgs=(/MPAS_POOL_INTEGER/)) + call mpas_log_write(' Logical: $i', intArgs=(/MPAS_POOL_LOGICAL/)) + call mpas_log_write(' Character: $i', intArgs=(/MPAS_POOL_CHARACTER/)) -! write(stderrUnit, *) 'Pool Size:' +! call mpas_log_write('Pool Size:') ! call pool_print_table_size(pool) call mpas_pool_begin_iteration(pool) do while(mpas_pool_get_next_member(pool, poolItr)) if (poolItr % memberType == MPAS_POOL_SUBPOOL) then - write(stderrUnit, *) '** Found subpool named: ', trim(poolItr % memberName) + call mpas_log_write('** Found subpool named: ' // trim(poolItr % memberName)) call mpas_pool_get_subpool(pool, trim(poolItr % memberName), subpool) call pool_print_members(subpool) else if (poolItr % memberType == MPAS_POOL_CONFIG) then - write(stderrUnit, *) ' Config Option: ', trim(poolItr % memberName), poolItr % dataType + call mpas_log_write(' Config Option: ' // trim(poolItr % memberName) // ' $i', intArgs=(/ poolItr % dataType/)) else if (poolItr % memberType == MPAS_POOL_DIMENSION) then - write(stderrUnit, *) ' Dimension: ', trim(poolItr % memberName), poolItr % dataType, poolItr % nDims + call mpas_log_write(' Dimension: ' // trim(poolItr % memberName) // ' $i $i', intArgs=(/poolItr % dataType, poolItr % nDims/)) else if (poolItr % memberType == MPAS_POOL_PACKAGE) then - write(stderrUnit, *) ' Package: ', trim(poolItr % memberName) + call mpas_log_write(' Package: ' // trim(poolItr % memberName)) else if (poolItr % memberType == MPAS_POOL_FIELD) then - write(stderrUnit, *) ' Field: ', trim(poolItr % memberName), poolItr % dataType, poolItr % nDims, poolItr % nTimeLevels + call mpas_log_write(' Field: ' // trim(poolItr % memberName) // ' $i $i $i', & + intArgs=(/poolItr % dataType, poolItr % nDims, poolItr % nTimeLevels/)) end if end do - write(stderrUnit, *) 'Done with pool' - write(stderrUnit, *) '' + call mpas_log_write('Done with pool') + call mpas_log_write('') end subroutine pool_print_members!}}} From 6c5011cd1b90f54f68c6376f9dfaa772817ab108 Mon Sep 17 00:00:00 2001 From: Pranay Reddy Kommera Date: Tue, 8 Aug 2017 11:10:14 -0700 Subject: [PATCH 24/28] acoustic_changes --- .../dynamics/mpas_atm_time_integration.F | 57 ++++++------------- 1 file changed, 18 insertions(+), 39 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 8e68448f9..4db3e6da6 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2017,7 +2017,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, wwAvg, rho_pp, cofwt, coftz, zxu, & a_tri, alpha_tri, gamma_tri, dss, & tend_ru, tend_rho, tend_rt, tend_rw, & - zgrid, cofwr, cofwz, w, divergence_3d + zgrid, cofwr, cofwz, w ! redefine ru_p to be perturbation from time t, change 3a ! temporary real (kind=RKIND), dimension(:,:), pointer :: ru @@ -2032,7 +2032,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign - real (kind=RKIND), pointer :: epssm, smdiv, smdiv_p_forward + real (kind=RKIND), pointer :: epssm real (kind=RKIND), pointer :: cf1, cf2, cf3 @@ -2059,7 +2059,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) - call mpas_pool_get_array_gpu(diag, 'divergence_3d', divergence_3d) +! call mpas_pool_get_array_gpu(diag, 'divergence_3d', divergence_3d) call mpas_pool_get_array_gpu(diag, 'cofwt', cofwt) call mpas_pool_get_array_gpu(diag, 'coftz', coftz) call mpas_pool_get_array_gpu(diag, 'cofrz', cofrz) @@ -2104,16 +2104,16 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, ! epssm is the offcentering coefficient for the vertically implicit integration. ! smdiv is the 3D divergence-damping coefficients. call mpas_pool_get_config(configs, 'config_epssm', epssm) - call mpas_pool_get_config(configs, 'config_smdiv', smdiv) - call mpas_pool_get_config(configs, 'config_smdiv_p_forward', smdiv_p_forward) +! call mpas_pool_get_config(configs, 'config_smdiv', smdiv) +! call mpas_pool_get_config(configs, 'config_smdiv_p_forward', smdiv_p_forward) call atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & rho_zz, theta_m, ru_p, rw_p, rtheta_pp, rtheta_pp_old, zz, exner, cqu, ruAvg, wwAvg, & rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & - tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & + tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 & + dts, small_step, epssm, cf1, cf2, cf3 & ) end subroutine atm_advance_acoustic_step @@ -2123,9 +2123,9 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & rho_zz, theta_m, ru_p, rw_p, rtheta_pp, rtheta_pp_old, zz, exner, cqu, ruAvg, wwAvg, & rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & - tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & + tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 & + dts, small_step, epssm, cf1, cf2, cf3 & ) use mpas_atm_dimensions @@ -2147,7 +2147,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rtheta_pp real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rtheta_pp_old - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence_3d +! real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence_3d real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu @@ -2191,7 +2191,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign integer, intent(in) :: small_step - real (kind=RKIND), intent(in) :: dts, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 + real (kind=RKIND), intent(in) :: dts, epssm, cf1, cf2, cf3 real (kind=RKIND), dimension(nVertLevels) :: ts, rs @@ -2208,7 +2208,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts -!$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, divergence_3d, rho_pp, & +!$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, rho_pp, & !$acc rw_p, wwavg, & !$acc zz, cellsonedge, cqu, dcedge, exner, invdcedge, & !$acc tend_ru, zxu, tend_rho, a_tri, alpha_tri, cofrz, & @@ -2218,21 +2218,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart if(small_step /= 1) then ! not needed on first small step -!$acc parallel num_workers(4) vector_length(32) -!$acc loop gang worker - do iCell = cellStart,cellEnd -!$acc loop vector - ! acoustic step divergence damping - forward weight rtheta_pp - see Klemp et al MWR 2007 - do k = 1,nVertLevels - rtheta_pp_tmp = rtheta_pp(k,iCell) - rtheta_pp(k,iCell) = (rtheta_pp(k,iCell) + smdiv_p_forward * (rtheta_pp(k,iCell)-rtheta_pp_old(k,iCell)))*zz(k,iCell) - rtheta_pp_old(k,iCell) = rtheta_pp_tmp - end do - end do -!$acc end parallel - -!$OMP BARRIER - !$acc parallel vector_length(32) !$acc loop gang do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? @@ -2248,8 +2233,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) & - - smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) + ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) end do ! accumulate ru_p for use later in scalar transport @@ -2279,7 +2263,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels - ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) + ru_p(k,iEdge) = dts*tend_ru(k,iEdge) end do !DIR$ IVDEP !$acc loop vector @@ -2302,6 +2286,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rtheta_pp_old(1:nVertLevels,iCell) = 0.0 end do !$acc end parallel + else + do iCell=cellStart,cellEnd + rtheta_pp_old(1:nVertLevels,iCell) = rtheta_pp(1:nVertLevels,iCell) + end do end if @@ -2322,15 +2310,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !MGD moved to loop above over all cells ! rtheta_pp_old(1:nVertLevels,iCell) = 0.0 rw_p(:,iCell) = 0.0 - divergence_3d(1:nVertLevels,iCell) = 0. end if - if(small_step /= 1) then -! else ! reset rtheta_pp to input value; - ! rtheta_pp_old stores input value for use in div damping on next acoustic step. - ! Save rho_pp to compute d_rho_pp/dt to get divergence for next acoustic filter application. - rtheta_pp(1:nVertLevels,iCell) = rtheta_pp_old(1:nVertLevels,iCell) - divergence_3d(1:nVertLevels,iCell) = rho_pp(1:nVertLevels,iCell) - end if !$acc loop seq do i=1,nEdgesOnCell(iCell) @@ -2418,7 +2398,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & -coftz(k ,iCell)*rw_p(k ,iCell)) - divergence_3d(k,iCell) = (rho_pp(k,iCell) - divergence_3d(k,iCell))*rdts end do end do ! end of loop over cells From b851de4ca3ae641d640841934d06d97e72746e01 Mon Sep 17 00:00:00 2001 From: Pranay-Reddy-Kommera Date: Tue, 8 Aug 2017 14:27:56 -0700 Subject: [PATCH 25/28] finalAcousticChangesTested --- src/Makefile | 2 +- src/core_atmosphere/dynamics/Makefile | 2 +- .../dynamics/mpas_atm_time_integration.F | 11 +++++++---- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Makefile b/src/Makefile index e9991d762..d5f158404 100644 --- a/src/Makefile +++ b/src/Makefile @@ -15,7 +15,7 @@ endif all: mpas mpas: $(AUTOCLEAN_DEPS) externals frame ops dycore drver - $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -Mvect=noaltcode -acc -ta=tesla:cc60 + $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -acc -ta=tesla:cc60 externals: $(AUTOCLEAN_DEPS) ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" all ) diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 14c68b183..761ca07bc 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -18,5 +18,5 @@ ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -Mvect=noaltcode -acc -ta=tesla:cc60 -Minfo + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -acc -ta=tesla:cc60 -Minfo endif diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4db3e6da6..12bfbce24 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2207,7 +2207,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart c2 = cp * rcv resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts - + !$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, rho_pp, & !$acc rw_p, wwavg, & !$acc zz, cellsonedge, cqu, dcedge, exner, invdcedge, & @@ -2281,15 +2281,18 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart if (small_step == 1) then ! initialize here on first small timestep. !$acc parallel vector_length(32) -!$acc loop gang +!$acc loop gang vector do iCell=cellStart,cellEnd rtheta_pp_old(1:nVertLevels,iCell) = 0.0 end do !$acc end parallel else +!$acc parallel vector_length(32) +!$acc loop gang vector do iCell=cellStart,cellEnd rtheta_pp_old(1:nVertLevels,iCell) = rtheta_pp(1:nVertLevels,iCell) end do +!$acc end parallel end if @@ -4560,8 +4563,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! The integration coefficients were precomputed and stored in defc_a and defc_b !!$acc kernels -!$acc parallel vector_length(64) if (config_horiz_mixing == "2d_smagorinsky") then +!$acc parallel vector_length(64) !$acc loop gang private(d_diag,d_off_diag) do iCell = cellStart,cellEnd !$acc cache(d_diag) @@ -4591,9 +4594,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 - end if !$acc end parallel + end if ! else if(config_horiz_mixing == "2d_fixed") then From 73b2b35a86cb74481f2b6db8526a8328b5b5362f Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 6 Dec 2017 15:57:27 -0700 Subject: [PATCH 26/28] Remove halo exchanges for 'divergence_3d', which no longer exists as of v5.1 The divergence_3d field was used by the 3-d divergence damping mechanism that was included in MPAS v5.0. However, in MPAS v5.1, this mechanism was replaced with one that does not make use of a 'divergence_3d' field. Accordingly, the call to obtain a pointer to this field and to exchange that field's halo need to be removed. --- .../dynamics/mpas_atm_time_integration.F | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 12bfbce24..42c639d7d 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -189,7 +189,6 @@ subroutine atm_srk3(domain, dt, itimestep) type (field2DReal), pointer :: pressure_p_field type (field2DReal), pointer :: rtheta_p_field type (field2DReal), pointer :: rtheta_pp_field - type (field2DReal), pointer :: divergence_3d_field type (field2DReal), pointer :: tend_u_field type (field2DReal), pointer :: u_field type (field2DReal), pointer :: w_field @@ -209,7 +208,7 @@ subroutine atm_srk3(domain, dt, itimestep) logical, parameter :: debug = .false. real (kind=RKIND), dimension(:,:), pointer :: gpu_theta_m_1, gpu_theta_m_2, gpu_pressure_p, gpu_rtheta_p, gpu_exner - real (kind=RKIND), dimension(:,:), pointer :: gpu_rtheta_pp, gpu_divergence_3d, gpu_u_1, gpu_u_2, gpu_w_1, gpu_w_2 + real (kind=RKIND), dimension(:,:), pointer :: gpu_rtheta_pp, gpu_u_1, gpu_u_2, gpu_w_1, gpu_w_2 real (kind=RKIND), dimension(:,:), pointer :: gpu_tend_u, gpu_ru_p, gpu_rw_p, gpu_rho_pp, gpu_pv_edge, gpu_rho_edge real (kind=RKIND), dimension(:,:,:), pointer :: gpu_scalars_1 integer :: rrpk_rank, rrpk_devices, rrpk_local_gpu_id @@ -757,13 +756,8 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) call mpas_pool_get_array_gpu(diag,'rtheta_pp',gpu_rtheta_pp) - call mpas_pool_get_array_gpu(diag,'divergence_3d',gpu_divergence_3d) -!$acc update host(gpu_rtheta_pp,gpu_divergence_3d) call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 1 /)) - call mpas_pool_get_field(diag, 'divergence_3d', divergence_3d_field) - call mpas_dmpar_exch_halo_field(divergence_3d_field, (/ 1 /)) -!$acc update device(gpu_rtheta_pp,gpu_divergence_3d) end do ! end of acoustic steps loop @@ -2059,7 +2053,6 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array_gpu(diag, 'ruAvg', ruAvg) call mpas_pool_get_array_gpu(diag, 'wwAvg', wwAvg) call mpas_pool_get_array_gpu(diag, 'rho_pp', rho_pp) -! call mpas_pool_get_array_gpu(diag, 'divergence_3d', divergence_3d) call mpas_pool_get_array_gpu(diag, 'cofwt', cofwt) call mpas_pool_get_array_gpu(diag, 'coftz', coftz) call mpas_pool_get_array_gpu(diag, 'cofrz', cofrz) @@ -2147,7 +2140,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rtheta_pp real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rtheta_pp_old -! real (kind=RKIND), dimension(nVertLevels,nCells+1) :: divergence_3d real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu From 8cd783b9f3c69bda229f0896e3ca06ac3f795ed9 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 6 Dec 2017 16:23:15 -0700 Subject: [PATCH 27/28] Remove hardwired PGI OpenACC flags, activate OpenACC with "OPENACC=true" The Makefiles in the src/ and src/core_atmosphere/dynamics/ directories had hard-wired OpenACC flags that were specific to the PGI compiler. These prevented the code from being compiled with any other compilers, or from being compiled without OpenACC. This commit removes hard-wired, compiler-specific flags from lower-level Makefiles, and instead allows OpenACC flags to be specified in a compiler-dependent way in the top-level Makefile. Compiling with OpenACC is now accomplished by adding "OPENACC=true" to the build command. At present, only OpenACC flags for the PGI compiler are provided, and there are not checks to ensure that the compiler actually does support OpenACC. --- Makefile | 67 +++++++++++++++++++ src/Makefile | 2 +- src/core_atmosphere/dynamics/Makefile | 2 +- .../dynamics/mpas_atm_time_integration.F | 8 +++ 4 files changed, 77 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index b569fe250..a73b8ddd9 100644 --- a/Makefile +++ b/Makefile @@ -23,10 +23,13 @@ xlf: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) ftn: @@ -44,10 +47,13 @@ ftn: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) titan-cray: @@ -62,10 +68,13 @@ titan-cray: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pgi: @@ -87,10 +96,13 @@ pgi: "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC = -Mnofma -acc -ta=tesla:cc60 -Minfo" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pgi-nersc: @@ -108,10 +120,13 @@ pgi-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pgi-llnl: @@ -129,10 +144,13 @@ pgi-llnl: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) ifort: @@ -154,10 +172,13 @@ ifort: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) ifort-scorep: @@ -179,10 +200,13 @@ ifort-scorep: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) ifort-gcc: @@ -204,10 +228,13 @@ ifort-gcc: "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) gfortran: @@ -229,10 +256,13 @@ gfortran: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) gfortran-clang: @@ -254,10 +284,13 @@ gfortran-clang: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) g95: @@ -275,10 +308,13 @@ g95: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) pathscale-nersc: @@ -296,10 +332,13 @@ pathscale-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) cray-nersc: @@ -317,10 +356,13 @@ cray-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) gnu-nersc: @@ -361,6 +403,8 @@ intel-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -FR -CU -CB -check all -gen-interfaces -warn interfaces -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ @@ -369,6 +413,7 @@ intel-nersc: "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) bluegene: @@ -390,10 +435,13 @@ bluegene: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) CPPINCLUDES = @@ -514,6 +562,13 @@ ifeq "$(OPENMP)" "true" LDFLAGS += $(FFLAGS_OMP) endif #OPENMP IF +ifeq "$(OPENACC)" "true" + FFLAGS += $(FFLAGS_ACC) + CFLAGS += $(CFLAGS_ACC) + override CPPFLAGS += "-DMPAS_OPENACC" + LDFLAGS += $(FFLAGS_ACC) +endif #OPENACC IF + ifeq "$(PRECISION)" "single" CFLAGS += "-DSINGLE_PRECISION" CXXFLAGS += "-DSINGLE_PRECISION" @@ -586,6 +641,12 @@ else OPENMP_MESSAGE="MPAS was built without OpenMP support." endif +ifeq "$(OPENACC)" "true" + OPENACC_MESSAGE="MPAS was built with OpenACC enabled." +else + OPENACC_MESSAGE="MPAS was built without OpenACC support." +endif + ifneq ($(wildcard .mpas_core_*), ) # CHECK FOR BUILT CORE ifneq ($(wildcard .mpas_core_$(CORE)), ) # CHECK FOR SAME CORE AS ATTEMPTED BUILD. @@ -686,6 +747,10 @@ ifeq "$(OPENMP)" "true" @rm -fr conftest.* endif +ifeq "$(OPENACC)" "true" + @echo "Testing compiler for OpenACC support" +endif + mpas_main: compiler_test ifeq "$(AUTOCLEAN)" "true" @@ -723,6 +788,7 @@ endif @echo $(PAPI_MESSAGE) @echo $(TAU_MESSAGE) @echo $(OPENMP_MESSAGE) + @echo $(OPENACC_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) endif @@ -804,6 +870,7 @@ errmsg: @echo " TIMER_LIB=gptl - Uses gptl for the timer interface instead of the native interface" @echo " TIMER_LIB=tau - Uses TAU for the timer interface instead of the native interface" @echo " OPENMP=true - builds and links with OpenMP flags. Default is to not use OpenMP." + @echo " OPENACC=true - builds and links with OpenACC flags. Default is to not use OpenACC." @echo " USE_PIO2=true - links with the PIO 2 library. Default is to use the PIO 1.x library." @echo " PRECISION=single - builds with default single-precision real kind. Default is to use double-precision." @echo "" diff --git a/src/Makefile b/src/Makefile index d5f158404..b0004ba4d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -15,7 +15,7 @@ endif all: mpas mpas: $(AUTOCLEAN_DEPS) externals frame ops dycore drver - $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -acc -ta=tesla:cc60 + $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time externals: $(AUTOCLEAN_DEPS) ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" all ) diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 761ca07bc..97785deb4 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -18,5 +18,5 @@ ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 -r8 -O3 -byteswapio -Mfree -m64 -Mnofma -acc -ta=tesla:cc60 -Minfo + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 12bfbce24..ef6c33f0f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -26,7 +26,11 @@ module atm_time_integration #endif use mpas_atm_iau + +#ifdef MPAS_OPENACC use openacc +#endif + integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables @@ -212,11 +216,15 @@ subroutine atm_srk3(domain, dt, itimestep) real (kind=RKIND), dimension(:,:), pointer :: gpu_rtheta_pp, gpu_divergence_3d, gpu_u_1, gpu_u_2, gpu_w_1, gpu_w_2 real (kind=RKIND), dimension(:,:), pointer :: gpu_tend_u, gpu_ru_p, gpu_rw_p, gpu_rho_pp, gpu_pv_edge, gpu_rho_edge real (kind=RKIND), dimension(:,:,:), pointer :: gpu_scalars_1 + +#ifdef MPAS_OPENACC integer :: rrpk_rank, rrpk_devices, rrpk_local_gpu_id rrpk_rank = domain % dminfo % my_proc_id rrpk_devices = acc_get_num_devices(acc_device_nvidia) rrpk_local_gpu_id = mod(rrpk_rank,rrpk_devices) call acc_set_device_num(rrpk_local_gpu_id,acc_device_nvidia) +#endif + ! ! Retrieve configuration options ! From c23b39a3cbcc3af010805db403931a8b0a3564e3 Mon Sep 17 00:00:00 2001 From: Pranay-Reddy-Kommera Date: Sat, 13 Jan 2018 12:14:34 -0800 Subject: [PATCH 28/28] Fix compilation error using netcdf_nf_data --- src/framework/mpas_io.F | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index e04e6bda3..206280587 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -12,6 +12,10 @@ module mpas_io use mpas_dmpar use mpas_log +#ifndef USE_PIO2 + use netcdf_nf_data +#endif + use pio use piolib_mod use pionfatt_mod