!+ Source Module for writing Grib files !------------------------------------------------------------------------------ #ifdef MESSY #define STATIC_FIELDS #endif MODULE src_output !------------------------------------------------------------------------------ ! ! Description: ! This module contains subroutines necessary for writing the result data ! of the LM. It uses also routines from the module "io_utilities". ! ! Current Code Owner: DWD, Ulrich Schaettler ! phone: +49 69 8062 2739 ! fax: +49 69 8062 3721 ! email: ulrich.schaettler@dwd.de ! ! History: ! Version Date Name ! ---------- ---------- ---- ! 1.1 1998/03/11 Ulrich Schaettler ! Initial release ! 1.2 1998/03/30 Ulrich Schaettler ! Regarding whether digital filtering has been performed. ! 1.7 1998/07/16 Guenther Doms ! Use of additional global fields to perform output of non-global fields. ! 1.8 1998/08/03 Ulrich Schaettler ! Use grib parameters from module data_io.f90. ! 1.9 1998/09/16 Guenther Doms ! Use of parameters 'nincmxt' and 'nincmxu' (replacing 'nincmxn') from ! data module 'data_runcontrol.f90'. ! 1.10 1998/09/29 Ulrich Schaettler ! Eliminate dependency from routine remark. ! 1.14 1998/10/26 Ulrich Schaettler ! Changed igds to igds_out. ! 1.17 1998/11/17 Ulrich Schaettler ! Changes for reading and writing ready files and constant variables. ! 1.20 1999/01/07 Guenther Doms ! Renaming of some global variables ! 1.24 1999/03/01 Guenther Doms ! Inclusion of the new prognostic 3-D array 'qi'. ! 1.29 1999/05/11 Ulrich Schaettler ! Adapted interfaces to utility-modules and prepared use of MPE_IO; ! Subroutine tautsp has been put to module utilities.f90 ! 1.30 1999/06/24 Matthias Raschendofer ! Use 6 additional fields: t, t_g, qv_s, tfm, tfh, tke, gz0. ! Use 1 additional parameter form module data_runcontrol: ntke ! 1.32 1999/08/24 Guenther Doms ! Use of postprocessing utilities from new routine 'pp_utilities' ! 1.33 1999/10/14 Guenther Doms ! Use of postprocessing utility 'caliq' from 'pp_utilities'. ! 1.34 1999/12/10 Ulrich Schaettler ! Use new Namelist variables and include all module procedures in this file ! 1.38 2000/04/06 Christoph Schraff ! Correction for mean values when writing analyses (in 'output_grib_data'). ! 1.39 2000/05/03 Ulrich Schaettler ! Changed names for variables concerned to latitude or longitude. ! Introduced possibility for database IO. ! Prepared output for different nests (for interactive nesting). ! 1.40 2000/05/23 Ulrich Schaettler ! No interpolation to masspoints for u,v for p- and z-interpolation. ! 2.8 2001/07/06 Ulrich Schaettler ! Eliminated non-necessary variables from the USE-lists; ! Adapted input to new organization of I/O; ! Introduced 2D version of p- and z-interpolation ! 2.10 2001/07/24 Ulrich Schaettler ! Corrected declaration of my_iee in subroutine output_grib_data ! 2.11 2001/09/28 Ulrich Schaettler ! Eliminated extensive use of LEN_TRIM (which was not performant on e.g. NEC) ! Corrected a bug when gribbing the pole of the rotation grid (igds_out(21)) ! 2.14 2002/02/15 Ulrich Schaettler ! Modifications for computation of the height of the snow-fall limit ! Correction in the grib-coding of the upper right corner (igds_out(11)) ! 2.17 2002/05/08 Ulrich Schaettler ! Modifications to perform I/O-communications in irealgrib-format ! 2.19 2002/10/24 Ulrich Schaettler ! Corrected bugs in writing variables from multi-layer soil model and ! in calculating the gds-values in case of luvmasspoints=.TRUE. ! 3.5 2003/09/02 Ulrich Schaettler ! Include output for zenith delay (routine calztd from pp_utilities) ! Include output for ICW, ICI (integrated cloud water; integrated cloud ice) ! Corrected output for calrelhum, calomega ! 3.6 2003/12/11 Ulrich Schaettler ! Adaptations for multi-layer soil model ! 3.7 2004/02/18 Ulrich Schaettler ! Adaptations for output of synthetic satellite images as GRIB fields; ! Possibility for specifying additional GRIB tables ! Renamed phi to rlat ! 3.8 2004/03/23 Ulrich Schaettler ! Bug-Fix in the treatment of the linked-list for Namelist group /GRIBOUT/ ! 3.13 2004/12/03 Ulrich Schaettler ! Put KIND-parameters for Grib-library to data_parameters; ! Changed W_ICE to W_SO_ICE (Reinhold Schrodin) ! Adaptations for output of new variables (graupel scheme, 3D turbulence) ! Possibility to write 3dimensional variables on p- and z-levels ! (Thorsten Reinhardt, Jochen Foerstner) ! Bug correction for writing gds for u and v in case of p- or z-levels ! (Emanuele Zala) ! 3.15 2005/03/03 Ulrich Schaettler ! Replaced FLOAT by REAL; Implemented NL variable nunit_of_time ! 3.16 2005/07/22 Ulrich Schaettler ! Adapted length of pathname for output-directory ! Calculate new fields for output of radar images ! 3.18 2006/03/03 Ulrich Schaettler ! Introduction of writing NetCDF and Restart files ! Changed treatment of ASCII files for introducing restart possibility ! Added output variables TQR, TQS, TQG, RELHUM_2M ! Changes to introduce new type of coding the vertical coordinate parameters ! (introduced by MeteoSwiss for SLEVE vertical coordinate) ! Introduction of ldwd_grib_use: if .TRUE., special non-standard Grib Code ! settings used at DWD are done (setting of ipds(4), tri, reference time ! for some analysis products) ! Introduction of possibility to write a subdomain field ! Determination of grib record length now by return value idims_out(19) from ! routine grbex1 (instead of idims_out(18)*iwlength) ! New routines for NetCDF: write_nc_gdefs, write_nc_vdefs ! New routines smooth_pmsl, smooth_geopot for extreme smoothing pmsl, geopot ! in mountainous terrain (introduced by Bundeswehr ! 3.19 2006/04/25 Ulrich Schaettler ! Corrections in the NetCDF output ! 3.21 2006/12/04 Ulrich Schaettler ! changes in write_nc_gdefs to meet netCDF CF standards (B. Rockel) ! Correction for specifying soil types for NetCDF output ! land/sea masks in netCDF output included ! polgam introduced ! Save the vertical coordinate parameters in restart files (U. Schaettler) ! Use nnow for output ! Adaptations for Ensemble Prediction output (C. Gebhardt) ! Additional output of several convective indices (D. Leuenberger) ! Time integrated analysis increment fields introduced (C. Schraff) ! V3_23 2007/03/30 Jochen Foerstner, Michael Baldauf, Ulrich Schaettler ! Corrected computation of q_sedim (must be done with qi(:,:,:,nnew) ! Added call to SR calc_ceiling ! Introduced idbg_level for verbosity of output ! V3_24 2007/04/26 Ulrich Schaettler ! Eliminated nincmxu, nincmxt and introduced control as for other increments ! V3_25 2007/05/21 Ulrich Schaettler ! Corrections for writing synthetic satellite images for MSG2 ! Modifications for writing lat/lon values to NetCDF files ! V3_26 2007/05/29 Ulrich Schaettler ! More debug level output ! V3_27 2007/06/29 Ulrich Schaettler ! Additional correction for flexible dt in makepds for writing analysis ! V4_1 2007/12/04 Ulrich Schaettler ! Corrected settings of igds_out for ivctype=3 ! Bug fix for re-initializing rain rates after restart files (Uwe Boehm) ! Introduced output for SDI (supercell detection indices) ! Introduced additional clipping of variables, if values are around 0 ! (only for grib-output) ! V4_3 2008/02/25 Ulrich Schaettler ! Omit grib warnings in case of climate simulations ! V4_4 2008/07/16 Ulrich Schaettler ! Changed NL parameter lyear_360 to itype_calendar, to have several options ! Adapted interface of get_timings ! V4_5 2008/09/10 Guenther Zaengl ! Adaptations for new reference atmosphere ! V4_8 2009/02/16 Ulrich Schaettler, Guenther Zaengl ! Corrections for NetCDF Input and Grib Output ! Use noutlevels as maximum number of output levels ! Adapted interface to SR cal_conv_ind to changes in pp_utilities ! Adapted GDS encoding and restarts for new reference atmosphere ! Use p0hl (reference pressure at half levels) for full consistency with ! new reference atmosphere implementation ! Bug fix for grib encoding of LM output (affects only sleve coordinate and ! new reference atmosphere) ! Add l_ke_in_gds to partly replace ldwd_grib_use ! V4_9 2009/07/16 Ulrich Schaettler, Burkhardt Rockel ! Corrections in closing YUCHKDAT ! Vectorization of p_int and z_int routines ! Adaptations for new reference atmosphere in netCDF output ! Include ivctype=2 and ivctype=3 in netCDF output ! V4_10 2009/09/11 MCH ! Computation and output of BRN and HPBL ! Added compiler directive to use option _on_adb for NEC ! V4_11 2009/11/30 Guenther Zaengl, Lucio Torrisi ! Adaptations for output using irefatm=3 (const. Brunt-Vaisala frequency) ! Adaptations for output of additional fluxes ! V4_12 2010/05/11 Michael Baldauf, Ulrich Schaettler ! Introduced output for potential and (relative) Vorticity ! Moved subroutine calc_sdi from pp_utilities to here because of formal reasons ! Renamed t0 to t0_melt because of conflicting names ! Added more convective indices fields for output; ! Introduced unit_of_time=15 for 10 minutes output (Oli Fuhrer) ! V4_13 2010/05/11 Michael Gertz ! Adaptions to SVN ! V4_15 2010/11/19 Ulrich Schaettler, Oliver Fuhrer ! Eliminated tgrlat, acrlat from interface to SR potential_vorticity_rho ! Use of nnow instead of itl (for itimelevel) in src_output for some variables ! VORTIC_U,_V,_W, POT_VORTIC, T_WATER, and SR caliq, calztd, calomega ! V4_17 2011/02/24 Ulrich Blahak ! - Adapted interface of exchg_boundaries; ! - corrected kzdims(1:20) -> kzdims(1:24); ! - eliminated my_peri_neigh; ! - implemented linear interpolation as alternative to ! cubic tension splines in SRs z_int() and pint() -- this uses ! the new interpolation routine lininterp2D_xinter1D_vec() ! from utilities.f90 and may be activated by the new namelist ! parameter itype_vertint in namelist group gribout (1=cubic spline, 2=linear); ! - surface values of U, V, W, and T ! for *linear* z_int()-interpolation now depend on lnosurffluxes_m/h (free-slip b.c or not) ! FOR NOW: THIS IS NOT DONE FOR P-LEVELS OUTPUT AND Z-LEVELS CUBIC ! SPLINES TO PRESERVE "OLD" BEHAVIOUR AND TO AVOID PROBLEMS ! WITH OVERSHOOTS IN CUBIC SPLINE INTERPOLATION. ! - surface value of pressure for z_int()-interpolation is now ! taken to be the surface pressure ps instead of p on the ! lowest main levels. This changes slightly the results ! of z-interpolated pressure near the surface. ! - changed variable name "result" ! to "results", since "result" is a fortran key word; ! - added debug output on processed variables for constant fields output. ! V4_18 2011/05/26 Ulrich Schaettler ! Introduced conditional compilation for synthetic satellite images ! Moved NL parameter yform_write to the group(s) /GRIBOUT/ to be able to ! specify the output format differently for every group. ! Adapted NetCDF I/O to deal with 3D external parameter field for sectors of ! the horizon (for topographical corrections) and its attributes (Anne Roches) ! Adapted NetCDF I/O to deal with synthetic satellite data (but only MSG) ! Introduced 4 additional fields for each group of products for syn sat data ! (Anne Roches et al.) ! More general if-clauses for SR caliq (Michael Baldauf) ! Bug fixes in calls to SR calc_Theta_Tppp and potential_vorticity_rho ! (reported by Jean-Marie Bettems) ! Exchange of boundaries for AUMFL_S, AVMFL_S, if luvmasspoint=.TRUE. ! V4_19 2011/08/01 Ulrich Schaettler ! Introduced conditional compilation for NetCDF and GRIBOUT ! Check inconsistent RTTOV- and OUTPUT-settings for synthetic satellite images ! (Robin Faulwetter) ! V4_20 2011/08/31 Ulrich Schaettler ! Replaced variablename namelist (which is Fortran Keyword) by outblock ! Bug fix for computing total pressure on highest half level (J. Schmidli) ! V4_21 2011/12/06 Ulrich Blahak ! Bugfixes p_int for the case itype_vertint=2 (linear vertical interpolation): ! - monotonically increasing (dummy) p-values are also required below the ! surface for routine lininterp2D_xinter1D_vec(). ! - error in field dimension when calling lininterp2D_xinter1D_vec ! (-> model crashes) was corrected. ! Bug in calling sequences of radar_lm_ray: The routine requires ! hydrometeor densities (kg/m**3), not specific values (kg/kg), so added ! necessary multiplications with rho. ! Initialized variable izerror in SR calc_sdi (Oli Fuhrer) ! V4_23 2012/05/10 Ulrich Schaettler, Oliver Fuhrer, H.-J. Panitz, Ulrich Blahak ! Use field sqrtg_r_s, dzeta_* from new module grid_metrics_utilities ! Added computation of total precipitation rate TOT_PR (Oli Fuhrer) ! The subroutine makegds is used by restart files and must not be embraced by ! ifdef GRIBDWD ! CLM: ! Added support for climatological year with 365 days ! Introduction of new diagnostic variable for maximum wind speed in 10m height ! Introduced new field snow_melt ! Correction of bug (?) related to definition of subregrions ! for netcdf output (Namelist parameter ydomain = 's') ! Only for climate mode: reset all necessary precipitation "components" like RAIN_GSP etc. ! to zero in case that only TOT_PREC is an output variable ! Comment a few lines in write_nc_gdefs that are not neede any more ! Changes to allow multi-layer snow model quantities in netCDF output ! New flag "i" to distinguish between ocean and inland water (lakes) quantities ! (for netCDF output only) ! Write global attributes in netCDF only if they are defined ! UB: ! Changed name of l_fi_ps_smooth to l_fi_pmsl_smooth and added l_fi_filter and ! l_pmsl_filter in order to be able to independently smooth FI and PMSL ! with a digital FIR filter, as for all other fields with l_z_filter / l_p_filter. ! Consequently, eliminated dependency of PMSL-smoothing from l_z_filter. ! V4_24 2012/06/22 Ulrich Schaettler, Hendrik Reich ! Conditional compilation for GRIBDWD in SR makegds: ! The vertical coordinate parameters can only be written, if GRIBDWD is set ! and the Grib library is available, because of packing of REALs to INTEGERs. ! In case of restart these parameters are not written, but also not needed ! Adapted length of strings for date variables (HR) ! Introduced new argument to SR make_fn (lmmss) ! V4_25 2012/09/28 Anne Roches, Oliver Fuhrer, Ulrich Blahak ! Florian Prill, Hans-Juergen Panitz, Carlos Osuna ! Replaced qx-variables by using them from the tracer module ! Implemented second type of gathering 2D fields from all PEs to the one PE that ! does the (Grib) packing (namelist switch itype_gather) (OF) ! UB: ! Introduced output of variables for the 2-moment microphysics (QHAIL, NCXXX, ! radar reflectivity by subroutine radar_sb_ray()). ! For z- and p-level interpolated DBZ and hydrometeor quantities (QX, NCXXX), ! hardwired the linear interpolation instead of cubic splines to ! prevent undershoots for these highly variable quantities. ! Added new namelist switch "outblock%loutput_q_densities" ! for the gribout namelist(s). If set to .true., hydrometeor variables qx, qnx ! are output in units of kg/m**3 resp. 1/m**3 instead of kg/kg resp. 1/kg. ! (default: .FALSE. = traditional output). ! Bugfixes: many changes to make all output fields really consistent ! to the chosen timelevel of output. Except for restart, this is ! "nnow" instead of "nnew" since V4.15! Changes are related mainly ! to rho, qrs, which are now correctly diagnosed before output on ! both timelevels "itimelevel" and "nnew" and stored in local variables. ! Adapted call to make_fn according to changes in io_utilities (Uli Schaettler) ! Adapted computation of reference time, if dt does not fit into the output interval ! Corrected writing of ready-files at the end of an output step (FP) ! Adapted interface to write_grib (FP) ! Introduced nexch_tag for MPI boundary exchange tag to replace ntstep (HJP) ! In case netcdf async I/O mode is selected, do not write data into netcdf ! file but send data to I/O PE instead. (CO) ! Add arguments to output_data subroutine needed to send metadata to asyn I/O PE ! Move write_nc_gdefs and write_nc_vdefs to netcdf_io.f90 ! V4_26 2012/12/06 Ulrich Blahak, Anne Roches, Ulrich Schaettler ! Hans-Juergen Panitz, Bojan Skerlak ! Changed "ytrans_out /= ' ' " to "LEN_TRIM(ytrans_out) > 0" (UB) ! The new diagnosis of rho and qrs must not be done in case of restart files, ! because this can not be re-constructed after a restart ! Bug fix for itype_gather=2 (AR) ! Bug fix for calling SR potential_vorticity_rho: the prognostic fields u, v ! and w have to be passed with the correct timelevel itl (BS) ! Write time level ntke for TKE scheme to binary restart file for correct ! TKE restart. (US) ! Always construct file name for constant fields with step 0, also for restarts (US) ! In case of asynchronous I/O print the name of the 'c' file correctly ! in file YUCHKDAT (HJP) ! V4_27 2013/03/19 Ulrich Schaettler, Astrid Kerkweg ! Use nmsgchan from data_satellites ! MESSy interface introduced: get diagnostic output (AK) ! V4_28 2013/07/12 Ulrich Schaettler ! Implemented grib_api for writing GRIB(1/2) data ! Use and set vertical coordinate parameters for output ! Moved subroutines for setting I/O meta data to new module io_metadata.f90 ! Removed Nest-handling from this subroutine ! Use subroutines and variables for vertical grid and reference atmospheres ! from module vgrid_refatm_utils ! Adapted interface to grib_api routines with special grib_api integer ! V4_29 2013-10-02 Ulrich Schaettler, Astrid Kerkweg (Messy), Ulrich Blahak ! Corrected placement of ifdef GRIBAPI for gribinit_loop ! Unification of MESSy interfaces and COSMO Tracer structure ! For the COSMO-Model only use vcoord and refatm from vgrid_refatm_utils ! Added check for upper bound of zlev resp. plev in z_int() and p_int() (UB) ! V4_30 2013/11/08 Ulrich Schaettler ! Renamed ipds to ipds_out to reflect usage for output ! V5_1 2014-11-28 Ulrich Schaettler, Ulrich Blahak, Oliver Fuhrer ! Jochen Foerstner ! Adapted interfaces to SR calsnowlmt, caltopdc, calhzero by providing the ! hhl reference profile instead of vertical coordinate parameters ! Adapted interface to function compute_grib_intbuffer_length ! Added calculation of full pressure P for output (US) ! Adjust meta data of microphysics tracers in case of loutput_q_densities=.true. ! Changed output directory of restart files to ydir_restart_out. (UB) ! Added interface to routines calc_dbz_vec() and calc_fallspeed_vec() from ! the radar forward operator. If using -DRADARFWO, this replaces the ! former calls to radar_lm_ray() for radar reflectivity. Note that ! radar_lm_ray() is one of the options offered in calc_dbz_vec(), so that ! it can still be used. ! Replaced ireals by wp (working precision) (OF) ! Renamed QN-variables with NC... (US) ! Modifications for COSMO-ART and volcanic ash simulations ! V5_3 2015-10-09 Ulrich Blahak, Matthias Raschendorfer ! Added the lightning potential index LPI as an output variable (UB) ! Take care that TKETENS output variable has the correct unit (MR) ! V5_3a 2015-11-24 Jochen Foerstner ! Replaced last ireals (within COSMO-ART) to wp ! V5_4d 2016-12-12 Davide Cesari ! Bug Fix when writing only a subdomain with grib-api ! V5_4e 2017-03-23 Ulrich Blahak ! Bug fix for allocation of array int_cmpr_tot in computation of LPI ! Bug fix for writing DBZ in case of RADARFWO ! V5_4f 2017-09-01 Ulrich Blahak, Ulrich Schaettler, Axel Hutt ! Added resetting of MAX variables with ntri=2 (new conv. cell track vars), ! but do not do this for the existing MAX variables which have their own ! time control for reset (TMAX_2M, TMIN_2M, VMAX_10M, VABSMX_10M, VGUST_DYN, VGUST_CON) ! Added some grib2 meta data for cell track variables. ! Adaptation of global communication for helper fields of LPI. ! Adaptation for RTTOV12 (AH) ! Eliminated RTTOV9 (US) ! V5_4g 2017-11-13 Ulrich Schaettler, Andre Walser ! Removed variable nvar ! Added the calulation of a new output field RAPA (random pattern) for SPPT ! V5_5 2018-02-23 Ulrich Blahak, ?? ! Added output of potential temperature 'PT' and virtual potential ! temperature 'THETA_V', also for pressure and zlevels interpolations (UB) ! Adaptations for using GCL ! V5_5a 2018-06-22 Katherine Osterried, Philippe Marti, Xavier Lapillonne ! Ulrich Blahak, Ulrich Schaettler ! Port to GPU using OpenACC. ! Blocking loop adapt, previously in j direction, adapted for GPU execution. ! Now using tension splines in full 3D and fixed a bug for variable nldim, ! where wrong section was passed to tautsp2D up to now ! Renamed Spline2d to Spline3d and change implementation to run in parallel. ! Added ydir_mielookup_read, ydir_mielookup_write to calls to calc_dbz_vec() (UB) ! Removed all iintegers (US) ! Use kind_parameters instead of data_parameters (US) ! V5_5b 2018-10-29 Ulrich Blahak ! Added a special section to write radar composites to restart files ! Renamed VTERM / EXT_DBZ to DUMMY_1 / DUMMY_2 (?) ! Modifications to interface of radar forward operator ! V5_6 2019-02-27 Ulrich Schaettler, Guy de Morsier ! Lockfile mechanism with argument llock_file in open_file and close_file ! V5_6b 2019-10-16 Pavel Khain, Ulrich Schaettler, Ulrich Blahak ! Katherine Osterried, Burkhardt Rockel ! Bug fix in call to SR radar_sb_ray (TWOMOM_SB) ! Additional tracers for CLOUDRAD (PK) ! Implemented namelist variable lzint_above_ground, to write z-levels on height ! above ground (lzint_above_ground) (US) ! Implemented computation of wind speed and direction, if requested for output (US) ! Renamed calc_dbz_vec() to calc_dbz_vec_modelgrid() and other modifications to ! calculate DBZ-variables (UB) ! Modifications to write restart files in NetCDF (KSO, BR) ! Bug fix for writing TKETENS: also use the TKE timelevel for TKETENS ! V5_7 2020-02-21 Andre Walser, Oliver Fuhrer, Jonas Jucker ! Ulrich Schaettler, Yannick Boetzel ! Renamed output variable RAPA to RAPA_SPPT (AW) ! Remove GCL bindings (has been moved inside exchg_boundaries) (OF) ! Port computations for LPI to GPU (JJ) ! Adapted to modified version of utilities (US) ! Made some OpenACC kernels asynchronous (YB) ! V5_7a 2020-05-11 Damian Wojcik et. al, Ulrich Schaettler, Astrid Kerkweg ! Added treatment of EULAG fields (DW) ! Writing special EULAG constants to restart file (DW) ! For serial runs the fields wmax_tot, buo_tot have to be computed for LPI filtering (US) ! Write the sfc-save fields to restart files, if vpp/=wp (US) ! Update of MESSy interface implementation (AK) ! V5_7b 2020-06-19 Ulrich Schaettler ! Fixed calculation of u and v on mass grid point to compute DD, SP ! V5_7c 2020-07-03 Ulrich Schaettler ! Fixed a bug in spline3D: upper bound of k-loop is nldim - 1!! ! V5_8 2020-10-23 Astrid Kerkweg, Ulrich Schaettler, Ronny Petrik (CLM), crCLIM ! Explicitely declare character length with clen in routine p_int/z_int (AK) ! Modified hailcast variable names (after they got official GRIB 2 variables) (US) ! Modifications for additional CLM diagnostics (RP) ! Added output for vertically integrated zonal and meridional water fluxes ! (TWATFLXU, TWATFLXV) (crCLIM, US) ! Fixed a bug in interpolation to pressure level: the surface pressure was not ! transferred to LOG-values for variable pexp. (US) ! V5_9 2021-02-25 Ulrich Schaettler, Burkhardt Rockel ! Added output of tiles for restart and GRIB1 data. Enlarged CASE statement ! to select output variables in the write-loop with rank 5 and check for ! tile variables; adapted in which case statement special variables ! are treated, because the have a modified rank now. ! Array zvarlev now has an additional dimension for the tiles: 0:ntiles ! The number of the tile is written to the additional element number, which ! is a new argument in the SR output_data ! Introduce now%lwrite_tiles in parameter list of write_nc_vdefs (BR) ! Modifications also to subroutines p_int, z_int ! Enabled p-/z-interpolation of TKE by using ylistname, not yzname for selection ! V5_9a 2021-05-18 Astrid Kerkweg, Ulrich Schaettler ! Bug fixes for MESSy interface implementation (AK) ! Removed lmulti_snow (US) ! V5_9b 2021-06-02 Ulrich Schaettler ! Special treatment for WSOIL_FLX, Q_ROFF: only ibot_w_so levels are written ! V5_10 2021-07-21 Ulrich Schaettler ! Check and set special vertical dimensions for T_SO_SAVE for NetCDF restarts ! Adapt the vertical index for T_SO_SAVE levels for check_record ! V5_12 2021-09-09 Ulrich Blahak, Jana Mendrok ! Adaptations to EMVORADO changes ! V5_13 2021-11-09 Astrid Kerkweg ! Added additional tile-dimension to zvarlev in EULAG code ! V5_14 2021-12-07 Ulrich Schaettler ! Editorial changes ! V6_1 2023-08-24 Stefan Ruedisuehli ! Introduce intermediate pointer zverp5_ptr to fix pressure level output of ! variables with 5D arrays in GPU runs ! V6_x 2024-09-02 Ulrich Schaettler ! Bug fix in SR output_data when calling write_netcdf: ! for normal output, the full field ds_grib has been passed, but it needs the ! cutted out subdomain: ds_out ! ! Code Description: ! Language: Fortran 90. ! Software Standards: "European Standards for Writing and ! Documenting Exchangeable Fortran 90 Code". !============================================================================== ! ! Modules used: #ifdef GRIBAPI USE grib_api #endif USE kind_parameters, ONLY : & wp, & ! KIND-type parameter for real variables sp, & ! KIND-type parameter for single precision variables dp, & ! KIND-type parameter for double precision variables vpp ! KIND-type parameter for variable precision physics USE data_fields, ONLY : & hhl, & ! geometrical height of model half levels hsurf, & ! height of surface topography llandmask, & ! landpoint mask fr_lake, & ! lake fraction in a grid element [0,1] ( - ) rlat, & ! geographical latitude rlon, & ! geographical longitude ( rad ) rain_gsp, & ! amount of rain from grid-scale precip. (sum) (kg/m2) snow_gsp, & ! amount of snow from grid-scale precip. (sum) (kg/m2) grau_gsp, & ! amount of graupel from grid-scale prec. (sum) (kg/m2) hail_gsp, & ! amount of hail from grid-scale prec. (sum) (kg/m2) rain_con, & ! amount of rain from convective precip. (sum) (kg/m2) snow_con, & ! amount of snow from convective precip. (sum) (kg/m2) snow_melt, & ! amount of snow melt (sum) (kg/m2) prr_gsp, & ! precipitation rate of rain, grid-scale (kg/m2*s) prs_gsp, & ! precipitation rate of snow, grid-scale (kg/m2*s) prg_gsp, & ! precipitation rate of graupel, grid-scale (kg/m2*s) prh_gsp, & ! precipitation rate of hail, grid-scale (kg/m2*s) prr_con, & ! precipitation rate of rain, convective (kg/m2*s) prs_con, & ! precipitation rate of snow, convective (kg/m2*s) pp, & ! deviation from the reference pressure ps, & ! surface pressure dp0, & ! pressure thickness of model layers rho0, & ! base-state density rho, & ! total air density p0, & ! base-state pressure of full model levels p0hl, & ! base-state pressure of half model levels t0, & ! base state temperature clc_sgs, & ! subgrid-scale stratiform cloud cover clc_con, & ! convective cloud cover top_con, & ! level index of convective cloud top bas_con, & ! level index of convective cloud base pptens ! pressure tendency USE data_fields, ONLY : & qrs, & ! specific precip. water content (kg/kg) crlat, & ! cosine of transformed latitude u, & ! zonal velocity v, & ! meridional velocity u_m, & ! zonal velocity on mass grid point v_m, & ! meridional velocity on mass grid point u_10m, & ! zonal wind in 10m ( m/s ) v_10m, & ! meridional wind in 10m ( m/s ) w , & ! vertical velocity t , & ! temperature tke, & ! SQRT(2*TKE); TKE='turbul. kin. energy' t_g, & ! weighted surface temperature ( k ) t_2m, & ! temperature in 2m ( K ) qv_2m, & ! specific water vapor content (kg/kg) w_snow, & ! water content of snow (m H2O) p_anai, & ! deviation from the reference pressure ( Pa ) qv_anai, & ! specific water vapor content (kg/kg) qc_anai, & ! specific cloud water content (via saturation adjustm) synme7, & ! synmsg, & ! fc, & ! coriolis-parameter ( 1/s ) fccos, & ! horizontal coriolis-parameter ( 1/s ) acrlat, & ! 1 / ( crlat * radius of the earth ) ( 1/m ) tgrlat, & ! tangens of transformed latitude -- wup_dur, & ! updraft duration ( s ) dhail, & ! maximum hail diameter ( mm ) wup_mask, & ! updraft mask -- pertstoph, & ! stochastic multiplier of physics tendencies wdirgeo_10m_freq ! frequency distribution of wind direction ( 1 ) USE data_modelconfig,ONLY : & czmls, & ! depth of the main soil layers in m czhls, & ! depth of the half soil layers in m msoilgrib, & ! grib coded depth of main soil levels in centimeters dlon, & ! grid point distance in zonal direction (in degrees) dlat, & ! grid point distance in meridional direction (in degrees) dt, & ! long time-step istartpar, & ! start index for computations in the parallel program jstartpar, & ! start index for computations in the parallel program iendpar, & ! end index for computations in the parallel program jendpar, & ! end index for computations in the parallel program istart, & ! start index for the forecast of w, t, qv, qc and pp iend, & ! end index for the forecast of w, t, qv, qc and pp jstart, & ! start index for the forecast of w, t, qv, qc and pp jend, & ! end index for the forecast of w, t, qv, qc and pp ie, & ! number of grid points in zonal direction ie_tot, & ! number of grid points in zonal direction total je, & ! number of grid points in meridional direction je_tot, & ! number of grid points in meridional direction total ie_max, & ! Max. of ie on all processors je_max, & ! Max. of je on all processors ke, & ! number of grid points in vertical direction ke_tot, & ! number of grid points in vertical direction total ke1, & ! KE+1 ke_soil, & ! number of layers in the multi-layer soil model ke_snow, & ! number of snow layers !_br 23.01.12 ntiles, & ! number or total tiles pollon, & ! longitude of the rotated north pole (in degrees, E>0) pollat, & ! latitude of the rotated north pole (in degrees, N>0) polgam, & ! angle between the north poles of the systems startlon_tot, & ! transformed longitude of the lower left grid point ! of the total domain (in degrees, E>0) startlat_tot, & ! transformed latitude of the lower left grid point ! of the total domain (in degrees, N>0) klv850, & ! hhl_prof, & ! a special hhl-profile eddlon, & ! 1 / dlon eddlat, & ! 1 / dlat raddeg, & ! factor for transforming rad to degree idt_qv, idt_qc, idt_qs, idt_qr, idt_qi, idt_qg, & idt_qh, idt_qnc, idt_qnr, idt_qni, idt_qns, idt_qnh, idt_qng, & idt_ncn USE data_constants, ONLY : & pi, & ! circle constant r_d, & ! gas constant for dry air r_v, & ! gas constant for water vapor r_earth, & ! mean radius of the earth (m) g, & ! gravity acceleration rdv, & ! r_d / r_v rvd_m_o, & ! r_v/r_d - 1 o_m_rdv, & ! 1 - r_d/r_v cp_d, & ! specific heat of dry air at constant pressure cpdr, & ! 1.0 / cp_d rcpv, & ! cp_d / cp_v - 1 t0_melt, & ! melting temperature p0ref, & ! reference pressure for Exner-function (Pa) rho_w, & ! density of liquid water rho_ice, & ! density of ice (kg/m^3) K_w, & ! dielectric constant for water K_ice, & ! dielectric constant for ice b1, & ! b2w, & ! b3, & ! b4w, & ! lh_v ! latent heat of condensation USE data_runcontrol, ONLY : & nlastmxu, & ! last step when vbmax was "nullified" nlastmxt, & ! last step when tmin, tmax were "nullified" nnew, & ! corresponds to ntstep + 1 nnow, & ! corresponds to ntstep nstart, & ! first time step of the forecast ntstep, & ! actual time step ntke, & ! actual TKE-time step, corresponds to ntstep nvers, & ! version number of experiment for documentation l2tls, & ! time integration by two timelevel RK-scheme (.TRUE.) ! else with split-explicit scheme (only for l2tls=FALSE!) lsppt, & ! switch, if .true., perturb the physical tendencies lsoil, & ! forecast with soil model leps, & ! switch ensemble mode on/off iepsmem, & ! ID of ensemble member (EPS) iepstot, & ! total number ensemble members (EPS) iepstyp, & ! ID of ensemble generation type (EPS) itype_turb, & ! type of turbulent diffusion parametrization lprog_tke, & ! prognostic treatment of TKE (for itype_turb=5/7) itype_gscp, & ! type of grid-scale precipitation physics lmetr, & ! lartif_data=.TRUE.: with metric terms ! =.FALSE.: or without metric terms ldfi, & ! whether digital filtering or not ibot_w_so, & ! number of hydrological active soil layers nhori, & ! number of sectors for the horizont array by the topographic ! correction of the radiation lradtopo, & ! if .TRUE., calculate topographic correction of radiation leulag, & ! forecast with EULAG integration scheme lcori_deep, & ! if =.TRUE.: take cos(phi) coriolis terms into account itype_calendar,&! for specifying the calendar used psm0, & ! initial value for mean surface pressure ps dsem0, & ! initial value for mean dry static energy msem0, & ! initial value for mean moist static energy kem0, & ! initial value for mean kinetic energy qcm0, & ! initial value for mean cloudwater content yakdat1, & ! actual date (ydate_ini+ntstep/dt) in the form ! ddmmyyyyhhmmss (day, month, year, hour, min, sec) l_cosmo_art, & ! if .TRUE., run the COSMO_ART luse_rttov, & ! if .true. calculate synthetic satellite images lhailcast USE data_runcontrol, ONLY : & ltime, & ! detailed timings of the program are given lroutine, & ! if .TRUE., run an operational forecast idbg_level, & ! to control the verbosity of debug output ldebug_io , & ! if .TRUE., debug output for I/O lprintdeb_all,& ! .TRUE.: all tasks print debug output ! .FALSE.: only task 0 prints debug output luse_rttov, & ! if rttov-library is used luse_radarfwo,& ! if emvorado is used lartif_data, & ! forecast with self-defined artificial data lperi_x, & ! if lartif_data=.TRUE.: periodic boundary conditions in x-dir. ! or with Davies conditions (.FALSE.) lperi_y, & ! if lartif_data=.TRUE.: periodic boundary conditions in y-dir. ! or with Davies conditions (.FALSE.) l2dim, & ! 2 dimensional runs nbl_exchg, & ! cur_outstep, & ! current output time step cur_outstep_idx,& ! index of current output time step cur_gribout_idx ! index of current gribout section USE data_parallel, ONLY : & lasync_io, & ! if .TRUE.: the model runs with extra PEs for ! asynchronous IO my_cart_id, & ! rank of this subdomain in the cartesian communicator num_compute, & ! number of compute PEs nc_asyn_io, & ! number of asynchronous I/O PEs (netcdf) icomm_cart, & ! communicator that belongs to the cartesian grid imp_reals, & ! determines the correct REAL type used in the model ! for MPI imp_grib, & ! determines the REAL type for the GRIB library imp_integers, & ! determines the correct INTEGER type used in the model ! for MPI imp_character, & ! determines the correct CHARACTER type used in the ! model for MPI nboundlines, & ! number of boundary lines of the domain for which ! no forecast is computed = overlapping boundary ! lines of the subdomains my_cart_neigh, & ! neighbors of this subdomain in the cartesian grid iexch_req, & ! stores the sends requests for the neighbor-exchange ! that can be used by MPI_WAIT to identify the send ldatatypes, & ! if .TRUE.: use MPI-Datatypes for some communications ltime_barrier, & ! if .TRUE.: use additional barriers for determining the ! load-imbalance ncomm_type, & ! type of communication nexch_tag, & ! tag to be used for MPI boundary exchange ! (in calls to exchg_boundaries) sendbuf, & ! sending buffer for boundary exchange: ! 1-4 are used for sending, 5-8 are used for receiving isendbuflen, & ! length of one column of sendbuf nproc, realbuf, intbuf USE data_io, ONLY : & irealgrib, & ! KIND-type parameter for real variables in the grib library iwlength, & ! length of an integer word in byte intgribf, & ! KIND-type parameter for fortran files in the grib library intgribc, & ! KIND-type parameter for C files in the grib library int_ga, & ! integer precision for grib_api: length of message in bytes clen, & ! length of short name nhour_restart, & ! start-, stop-, inc of writing restart files (tstep) nzmxid, & ! maximum number of NetCDF variabe IDs ydate_ini, & ! start of the forecast ymode_write, & ! mode for opening the (write) Grib files yform_read, & ! format of the (read) files ntrans_out, & ! Unit Number for writing ready-Files during output nuchkdat, & ! Unit number for checking the I/O data yuchkdat, & ! checking the I/O data ytrans_out, & ! directory for writing ready files #ifdef RADARFWO ydir_mielookup_read, & ! directory for reading Mie lookup tables ydir_mielookup_write, & ! directory for writing Mie lookup tables #endif nsma_stat, & ! status for soil moisture analysis npds, & ! Dimension for product definition section (pds) ngds, & ! Dimension for grid description section (gds) nbms, & ! Dimension for bit map section (bms) nbds, & ! Dimension for binary data section ndsup, & ! Dimension for dsup ndims, & ! Dimension for idims (contains all dimensions) lfd, & ! lfa, & ! Dimension for grib_api message in bytes lbm, & ! lds, & ! inrvert_out, & ! number of vertical coordinate parameters of output data ntrip, & ! maximum number of timing triples noutlevels, & ! maximum actual existing number of output levels itype_gather, & ! switch to determine gather method to use max_gribtabs, & ! maximum number of GRIB tables in LM variable table idwdednr, & ! grib edition number for DWD library undefgrib, & ! value for "undefined" in the grib routines undefncdf, & ! value for "undefined" in the netcdf routines undef, & ! the same as undefgrib but with other KIND-Parameter lst_gribtabs, & ! IDs of GRIB tables use nlocaldefnr, & ! local definition number for GRIB local section nactlocdefnr, & ! to overwrite Namelist parameter with some center default nprocess_ini_in, & ! process gener. identification for initial (analysis) nprocess_bd_in, & ! and for boundary (forecasts) data from input data lmmss, & ! 10/14 digits date format llockfiles ! indicates whether to use lock files or not USE data_io, ONLY : & ! Global arrays iblock, & ! array for gribed data ymessage, & ! array for grib2 message (in characters) idims_out, & ! array for all dimensions ibmap, & ! array for ipds_out, & ! product definition section for output igds_out, & ! grid description section ibms, & ! bit map section ibds, & ! binary data section dsup, & ! Parameter for grib routines ds_grib, & ! array for unpacked data ds_real, & ! array for unpacked data igrib1_id, & ! grib1 sample igrib2_id, & ! grib1 sample ! Global types and tables list_stat_proc, & ! table of variables for statistical processing idim_tsp, & ! dimension for this table pp_nl, & ! structure for gribout namelist var ! array for LM variable table USE data_io, ONLY : & lspdd, & ! compute wind speed and direction for diagnostics lspdd_10m, & ! compute wind speed and direction on 10m for diagnostics l_ke_in_gds, & ! explicit GDS entry for number of model levels l_ke_in_input, & ! explicit GDS entry for number of model levels in input data lbdclim, & ! boundary data in climate model ! PIK (D.Hauffe) ! (in climate mode also some external parameters have ! to be updated, which are held constant in forecast ! mode; e.g. plant cover, root depth) idims_id_out, & ! array for the IDs of the dimensions of netCDF ! formatted output yncglob_institution, & ! originating center name yncglob_title, & ! title string for the output yncglob_source, & ! program name and version yncglob_project_id, & ! identification of the project of simulation yncglob_experiment_id, & ! identification of the experiment of simulation yncglob_contact, & ! contact e.g. email address yncglob_references, & ! URL, report etc. ncglob_realization, & ! number of the realization of the experiment nechotop, & ! number of echotop levels for echo tops dbzthresh_echotop ! list of dbz-thresholds for echo tops (integer dBZ-values) USE src_tracer, ONLY : trcr_acc_update_device, trcr_acc_update_host #if defined RTTOV7 || defined RTTOV10 || defined RTTOV12 USE data_satellites, ONLY : & sat_compute, num_sensors, nmsgchan #endif #ifdef NUDGING USE data_nudge_all, ONLY : & yform_lansfc #endif !------------------------------------------------------------------------------ USE utilities, ONLY : & smoother, dfilt4, dfilt8, tautsp3D, uvrot2uv_vec, & phirot2phi, rlarot2rla, get_utc_date, & lininterp3D_xinter3D_vec USE pp_utilities, ONLY : & calpmsl, calprsum, caltopdc, calhzero, calsnowlmt, & calcldepth, calclmod, calomega, calrelhum, caliq, calztd, & radar_lm_ray, linear2dbz, cal_conv_ind, calc_ceiling, & calc_bulk_richardson, calc_pbl_brn, & lightning_potential_index, lpi_spatial_filter, & hor_moisture_convergence, & #ifdef TWOMOM_SB radar_sb_ray, & #endif #ifdef COSMOART max_in_pressure_layers, & #endif potential_vorticity_rho USE grid_metrics_utilities, ONLY : & sqrtg_r_s, & ! 1 / square root of G at scalar points ( 1/m ) dzeta_dlam, & ! d zeta / d lambda (for constant phi, z) ! at the scalar position ( 1 ) dzeta_dphi, & ! d zeta / d phi (for constant lambda, z) ! at the scalar position ( 1 ) wgtfac ! weighting factor for vertical interpolation ( 1 ) USE numeric_utilities, ONLY : & curl, calc_Theta_Tppp, mean_over_box, mean_cov_over_box, vert_avg USE environment, ONLY : & model_abort, get_free_unit, release_unit, exchg_boundaries USE meteo_utilities, ONLY: calrho USE parallel_utilities, ONLY : & gather_values, combine_subarrays, distribute_values, gather_field USE io_utilities, ONLY : & open_file, close_file, write_grib, write_gribapi, write_netcdf, & write_restart, make_fn, check_record, compute_grib_intbuffer_length USE io_metadata, ONLY : & set_vcoord_refatm_out, make_grib_init, make_grib_grid, & make_grib_product, makegds #ifdef NETCDF USE netcdf_io, ONLY : & send_asyn_io, nc_orgmdata_length, nc_varmdata_length, & write_nc_gdefs,write_nc_vdefs #endif USE time_utilities, ONLY: get_timings, i_computations_O, i_gather_data, & i_write_data, i_meta_data_w USE vgrid_refatm_utils, ONLY: vcoord, refatm, uuid_2char, uuid_out_string, & uuid_out, uuid_create USE src_artifdata, ONLY: lnosurffluxes_m, lnosurffluxes_h USE sfc_interface, ONLY: sfc_restart_copy_toijk #ifdef RADARFWO USE radar_mie_iface_cosmo_driver, ONLY: calc_dbz_vec_modelgrid, calc_fallspeed_vec_modelgrid USE radar_data_namelist, ONLY: nel_composite, ldo_composite, ldo_bubbles, lweightdbz #endif !------------------------------------------------------------------------------ #ifdef EULAG USE data_eulag_mpi, ONLY: & np, mp, lp USE data_eulag_constants, ONLY: & st USE data_eulag_gcrk, ONLY: & epp1 USE eulag_utilities, ONLY: & store_BAE, & get_height_BAE USE data_eulag_config, ONLY: & T_BAE_LR, & T_BAE_BT #endif !------------------------------------------------------------------------------ USE src_tracer, ONLY : & trcr_get, & #ifdef COSMOART trcr_get_block, & #endif trcr_errorstr #ifdef STATIC_FIELDS USE src_tracer, ONLY : t_nnew, t_nnow, t_nold #endif USE data_tracer, ONLY : T_ERR_NOTFOUND !------------------------------------------------------------------------------ #ifdef NETCDF USE netcdf, ONLY : & nf90_def_dim, & nf90_def_var, & nf90_enddef, & nf90_redef, & nf90_put_att, & nf90_put_var, & nf90_noerr, & nf90_strerror, & NF90_CHAR, & NF90_DOUBLE, & NF90_FLOAT, & NF90_GLOBAL, & NF90_UNLIMITED #endif #ifdef COSMOART USE data_cosmo_art, ONLY : lvolcano USE data_volcano, ONLY : & isp_ash, & ! number of volcanic ash species ash_scale, & ! scaling factors for computation of mass concentration trcr_idx_ash #endif #ifdef MESSY !MESSy/BMIL USE messy_main_channel_bi, ONLY: L_BM_ORIG_OUTPUT, L_FORCE_calcout & , cosmo_output_list, COSMOOUT & , LOUTPUT_NOW, js_COSMOm, js_COSMOp & , js_COSMOz, js_COSMOs, js_COSMOc USE messy_main_tools, ONLY: int2str #endif !============================================================================== IMPLICIT NONE !============================================================================== ! string variable to hold grid information CHARACTER (LEN=200) grid_mapping ! for smoothing fi and pmsl, the global hsurf-field is needed REAL (KIND=wp), ALLOCATABLE :: hsurf_tot(:,:) ! for filtering the lightning potential index: REAL (KIND=sp), ALLOCATABLE :: wmax_tot(:,:), buo_tot(:,:) ! for sp REAL (KIND=sp), ALLOCATABLE :: wmax_loc(:,:), buo_loc(:,:) ! for sp ! REAL (KIND=wp), ALLOCATABLE :: int_cmpr(:,:), int_cmpr_tot(:,:) ! for wp INTEGER :: & itimelevel, itl ! for storing the output timelevel #ifdef STATIC_FIELDS INTEGER :: trcr_itl #endif ! Some module variables INTEGER, SAVE :: & igribid ! ID of actual grib message ! pointers for tracers: REAL (KIND=wp), POINTER :: & qv (:,:,:)=> NULL() ,& ! QV at itl qc (:,:,:)=> NULL() ,& ! QC at itl qi (:,:,:)=> NULL() ,& ! QI at itl qg (:,:,:)=> NULL() ,& ! QG at itl qr (:,:,:)=> NULL() ,& ! QR at itl qs (:,:,:)=> NULL() ! QS at itl #ifdef TWOMOM_SB REAL (KIND=wp), POINTER :: & qh (:,:,:)=> NULL() ,& ! QH at itl qnr (:,:,:)=> NULL() ,& ! NCRAIN at itl qni (:,:,:)=> NULL() ,& ! NCICE at itl qns (:,:,:)=> NULL() ,& ! NCSNOW at itl qng (:,:,:)=> NULL() ,& ! NCGRAUPEL at itl qnh (:,:,:)=> NULL() ! NCHAIL at itl #endif #ifdef CLOUDRAD REAL (KIND=wp), POINTER :: & ncn (:,:,:)=> NULL() #endif #if defined TWOMOM_SB || defined CLOUDRAD REAL (KIND=wp), POINTER :: & qnc (:,:,:)=> NULL() ! NCCLOUD at itl #endif #ifdef COSMOART REAL (KIND=wp), POINTER :: & cash(:,:,:,:)=> NULL() ! cash at itl #endif REAL (KIND=wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: & zrho_itl, & ! Total density at timelevel itimelevel zqrs_itl ! QRS at timelevel itimelevel ! Local storage for OpenACC REAL (KIND=wp), ALLOCATABLE, DIMENSION(:,:,:) :: & zqc_itl, & ! qc*zrho_itl zqr_itl, & ! qr*zrho_itl zqs_itl, & ! qs*zrho_itl zqg_itl, & ! qg*zrho_itl zqi_itl ! qi*zrho_itl #ifdef TWOMOM_SB REAL (KIND=wp), ALLOCATABLE, DIMENSION(:,:,:) :: & zqh_itl , & ! qh*zrho_itl zqnc_itl, & ! qnr*zrho_itl zqnr_itl, & ! qnr*zrho_itl zqni_itl, & ! qni*zrho_itl zqns_itl, & ! qns*zrho_itl zqng_itl, & ! ngg*zrho_itl zqnh_itl ! qnh*zrho_itl #endif PRIVATE :: qv, qc, qi, qg, qr, qs, zrho_itl, zqrs_itl #ifdef TWOMOM_SB PRIVATE :: qh, qnr, qni, qns, qng, qnh #endif #ifdef CLOUDRAD PRIVATE :: ncn #endif #if defined TWOMOM_SB || defined CLOUDRAD PRIVATE :: qnc #endif #ifdef COSMOART PRIVATE :: cash #endif #ifdef MESSY LOGICAL, SAVE :: l_COSMO_now = .FALSE. ! output required by COSMO #endif ! Pointer and local variables needed for OpenACC port of derived types ! Derived not fully supported wihtin parallel region REAL (KIND=wp), DIMENSION(:,:), POINTER :: zvarp2_ptr REAL (KIND=wp), DIMENSION(:,:,:), POINTER :: zvarp3_ptr ! REAL (KIND=wp), DIMENSION(:,:,:,:), POINTER :: zvarp4_ptr ! REAL (KIND=wp), DIMENSION(:,:,:,:,:), POINTER :: zvarp5_ptr ! !============================================================================== ! Module procedures !============================================================================== CONTAINS !============================================================================== !+ Module procedure in src_output for initializing the output organization !------------------------------------------------------------------------------ SUBROUTINE init_output (root) !------------------------------------------------------------------------------ ! ! Description: ! The routine init_output initializes organizational variables of the ! output routines dealing with the grib code (such as the dimensions of ! the different grib code sections). Also the grid description section ! is initialized (except the location of the lower left grid point, because ! it depends on the variable (U,V or other)). ! ! Method: ! !------------------------------------------------------------------------------ ! Pointers with intent(in): TYPE (pp_nl), POINTER :: root !------------------------------------------------------------------------------ ! ! Local scalars: INTEGER :: i,i1,i2,i3,k,n, niostat, izerrstat, & nuedat, nzrecords, kbot, ktop, izerror, & iorg_data(4,0:num_compute-1), izdebug, & nzbytes, ntls, nend_tile, izaee LOGICAL :: lzwrite_ended, lzapi1_write, lzapi2_write CHARACTER (LEN=260) :: yname CHARACTER (LEN=25) :: yzroutine CHARACTER (LEN=80) :: yzerrmsg CHARACTER (LEN= 3) :: yzhead CHARACTER (LEN= 4) :: yzform_sfcana ! Local arrays: #ifndef MESSY REAL (KIND=wp) :: & zvarlev (ie,je,0:noutlevels,0:ntiles) ! variable for vertical interpolation #else REAL(KIND=wp), DIMENSION(:,:,:,:), POINTER :: zvarlev => NULL() TYPE(cosmo_output_list), POINTER :: channeli TYPE(cosmo_output_list), POINTER :: channele CHARACTER(LEN=9) :: chname CHARACTER(LEN=3) :: str INTEGER :: iout #endif INTEGER :: & ivar_id(nzmxid) ! NetCDF-ID of each variable in the list CHARACTER (LEN=100) :: & charbuf ! Local Pointers: TYPE (pp_nl), POINTER :: now ! !- End of header !============================================================================== !------------------------------------------------------------------------------ ! Section 1: Initializations !------------------------------------------------------------------------------ yzroutine = 'init_output' izerrstat = 0 izaee = 0 ! will be set by tile information later ! Initialize, whether additional debug output shall be done IF (ldebug_io) THEN IF (lprintdeb_all) THEN izdebug = idbg_level ELSE IF (my_cart_id == 0) THEN izdebug = idbg_level ELSE izdebug = 0 ENDIF ENDIF ELSE izdebug = 0 ENDIF IF (izdebug > 5) THEN WRITE (*,'(A)') ' src_output: starting init_output' ENDIF ! Set lfd, lds and lbm lds = ie_tot * je_tot lbm = 1875 nzbytes = 8 lfd = compute_grib_intbuffer_length(ie_tot, je_tot, nzbytes, iwlength) lfa = compute_grib_intbuffer_length(ie_tot, je_tot, nzbytes, 1) ! gives length in bytes ! Allocate GRIB arrays ALLOCATE (iblock(lfd), ibmap(lbm), STAT=izerrstat) ALLOCATE (ds_real(lds), ds_grib(lds), dsup(ndsup), STAT=izerrstat) ALLOCATE (ymessage(lfa), STAT=izerrstat) ! Set vertical coordinate parameters for output ! (this routine sets inrvert_out and pv_out) CALL set_vcoord_refatm_out ! Initializations for the grib library ! moving arraydimensions into idims ! declaration dimensions idims_out( 1) = npds idims_out( 2) = ngds idims_out( 3) = nbms idims_out( 4) = nbds idims_out( 5) = lbm idims_out( 6) = ndsup idims_out( 8) = lfd ! real dimensions idims_out(11) = 47 idims_out(12) = 25 + inrvert_out idims_out(13) = 3 idims_out(14) = 5 idims_out(16) = 0 ! idims_out(7,15,17) depend on the special namelist group and are set later ! Initialization for ivar_id (should be set also for non netcdf output) ivar_id(:) = 0 ! Set yzform_sfcana: important, if no NUDING is defined yzform_sfcana = 'grb1' #ifdef NUDGING yzform_sfcana = yform_lansfc #endif !------------------------------------------------------------------------------ ! Section 2: Set the grid description section for GRIB1 (DWDLIB, Restart) !------------------------------------------------------------------------------ CALL makegds !------------------------------------------------------------------------------ ! Section 3: Get grib samples and set constant meta data for grib_api !------------------------------------------------------------------------------ now => root lzapi1_write = .FALSE. lzapi2_write = .FALSE. gribinit_loop: DO !---------------------------------------------------------------------------- ! Section 3.1: Get grib samples !---------------------------------------------------------------------------- #ifdef GRIBAPI IF (izdebug > 5) THEN WRITE (*,'(A)') ' src_output: reading grib_api samples for GRIBOUT: ', now%nl_index ENDIF IF ((now%yform_write == 'api1') .OR. (yzform_sfcana == 'api1')) THEN IF (.NOT. lzapi1_write) THEN CALL grib_new_from_samples (igrib1_id, 'DWD_rotated_ll_7km_G_grib1', izerrstat) IF (izerrstat /= GRIB_SUCCESS) THEN PRINT *, ' *** Error in grib_new_from_sample: for api 1 ', izerrstat ENDIF lzapi1_write = .TRUE. ! further api1 GRIBOUT blocks do not need to read sample ENDIF ! clone this sample to igrib1_sample CALL grib_clone(igrib1_id, now%igribapi_id, izerrstat) IF (izerrstat /= GRIB_SUCCESS) THEN PRINT *, ' *** Error in grib_clone: from sample 1 ', izerrstat ENDIF ENDIF IF ((now%yform_write == 'api2') .OR. (yzform_sfcana == 'api2')) THEN IF (.NOT. lzapi2_write) THEN CALL grib_new_from_samples (igrib2_id, 'DWD_rotated_ll_7km_G_grib2', izerrstat) IF (izerrstat /= GRIB_SUCCESS) THEN PRINT *, ' *** Error in grib_new_from_sample: for api 2 ', izerrstat ENDIF ! check whether we need a UUID: CALL uuid_2char (vcoord%vc_uuid, uuid_out_string) IF (uuid_out_string == '78787878-7878-7878-7878-787878787878') THEN ! this is the transformation of the initialization with x IF (my_cart_id == 0) THEN ! Create a new UUID for the HHL file identifier CALL uuid_create(uuid_out) ! Distribute this uuid to all PEs DO i = 1, 16 charbuf(i:i) = uuid_out(i) ENDDO ENDIF IF (num_compute > 1) THEN CALL distribute_values (charbuf, 1, 0, imp_character, icomm_cart, izerrstat) ENDIF IF (my_cart_id /= 0) THEN DO i = 1, 16 uuid_out(i) = charbuf(i:i) ENDDO ENDIF CALL uuid_2char (uuid_out, uuid_out_string) vcoord%vc_uuid(:) = uuid_out(:) IF (my_cart_id == 0) THEN PRINT *, ' Created new UUID for HHL-VGrid: ', uuid_out_string ENDIF ENDIF lzapi2_write = .TRUE. ! further api2 GRIBOUT blocks do not need to read sample ENDIF ! clone this sample to igrib2_sample CALL grib_clone(igrib2_id, now%igribapi_id, izerrstat) IF (izerrstat /= GRIB_SUCCESS) THEN PRINT *, ' *** Error in grib_clone: from sample 2 ', izerrstat ENDIF ENDIF #endif !---------------------------------------------------------------------------- ! Section 3.2: Set constant grib meta data !---------------------------------------------------------------------------- IF (izdebug > 5) THEN WRITE (*,'(A)') ' src_output: setting constant GRIB meta data' ENDIF CALL make_grib_init(now) IF (ASSOCIATED(now%next)) THEN now => now%next ELSE EXIT gribinit_loop ENDIF ENDDO gribinit_loop !------------------------------------------------------------------------------ ! Section 4: Loop over all GRIBOUT blocks !------------------------------------------------------------------------------ ! All namelist groups are inquired, whether constant fields shall be written. ! If no further output is done in step 0, a ready-file is written (checked ! with lzwrite_ended) now => root lzwrite_ended = .FALSE. #ifdef MESSY iout = 0 #endif gribout_loop: DO !---------------------------------------------------------------------------- ! Section 4.1: Open YUCHKDAT !---------------------------------------------------------------------------- #ifdef MESSY iout = iout + 1 #endif IF ( (now%lcheck .EQV. .TRUE.) .AND. (my_cart_id == 0) ) THEN ! open file YUCHKDAT IF (izdebug > 5) THEN WRITE (*,'(A)') ' src_output: opening file YUCHKDAT' ENDIF OPEN(nuchkdat, FILE=yuchkdat, FORM= 'FORMATTED', STATUS='UNKNOWN', & POSITION='APPEND', IOSTAT=niostat) IF(niostat /= 0) THEN yzerrmsg = ' ERROR *** Error while opening file YUCHKDAT *** ' izerrstat = 2005 CALL model_abort (my_cart_id, izerrstat, yzerrmsg, yzroutine) ENDIF ENDIF !---------------------------------------------------------------------------- ! Section 4.2: Write file with constant fields, if required !---------------------------------------------------------------------------- IF (now%lwrite_const .EQV. .TRUE.) THEN IF (izdebug > 5) THEN WRITE (*,'(A)') ' src_output: writing file with constant fields' ENDIF ! Create the filename ! ------------------- yzhead = 'lf'//now%ydomain ! Construct filename of constant files always for step 0, also in case of restarts CALL make_fn (yzhead, ydate_ini, ydate_ini, now%ytunit,'c', 0 , dt, & now%lhour, itype_calendar, now%ydir, yname, lmmss, & izdebug, izerror) ! In case of netcdf, add extension '.nc' to filename IF (now%yform_write == 'ncdf' .OR. now%yform_write == 'nc-4') THEN yname = yname(1:LEN_TRIM(yname)) // '.nc' ENDIF ! Add optional suffix to filename IF ( LEN_TRIM(now%ysuffix) /= 0 ) THEN yname = yname(1:LEN_TRIM(yname)) // TRIM(now%ysuffix) ENDIF #ifdef MESSY IF (L_BM_ORIG_OUTPUT) THEN l_COSMO_now = .TRUE. #endif ! open the file ! ------------- IF ((now%yform_write /= 'ncdf' .AND. now%yform_write /= 'nc-4') & .OR. nc_asyn_io < 1) THEN IF (now%yform_write == 'bina') THEN ! get a free unit-number for Fortran OPEN CALL get_free_unit (nuedat) ENDIF CALL open_file (nuedat, ymode_write, now%yform_write, icomm_cart, my_cart_id, & num_compute, lasync_io, yname, llockfiles, idbg_level, & yzerrmsg, izerror) IF (izerror /= 0) THEN CALL model_abort (my_cart_id, 2031, yzerrmsg, yzroutine) ENDIF #ifdef NETCDF ! Write global headers for netcdf file ! ------------------------------------ IF ((now%yform_write == 'ncdf' .OR. now%yform_write == 'nc-4') & .AND. nc_asyn_io < 1) THEN CALL write_nc_gdefs (nuedat, now, icomm_cart, num_compute, 'c', & NF90_FLOAT, -1, yzerrmsg, izerror) IF (izerror /= 0) THEN CALL model_abort (my_cart_id, 8052, yzerrmsg, yzroutine) ENDIF CALL write_nc_vdefs (nuedat, now%nyvar_c, now%ilist_c, ivar_id, & now%luvmasspoint, now%lwrite_tiles,now%lcompress_netcdf, & icomm_cart, num_compute, 'c', NF90_FLOAT, & yzerrmsg, izerror) IF (izerror /= 0) THEN CALL model_abort (my_cart_id, 8053, yzerrmsg, yzroutine) ENDIF ENDIF #endif ENDIF #ifdef MESSY ENDIF #endif ! Write the headline in YUCHKDAT for the file with constant variables ! ------------------------------------------------------------------- IF ( (now%lcheck) .AND. (my_cart_id == 0) ) THEN WRITE (nuchkdat,'(A,I7)') & 'Check the constant data: ' WRITE (nuchkdat,'(A,A)') & ' File: ',TRIM(yname) WRITE (nuchkdat,'(A,I5,A,I5,A,I5)') & ' ie_tot =',ie_tot,' je_tot =',je_tot,' ke_tot =',ke_tot WRITE (nuchkdat,'(A)') ' ' WRITE (nuchkdat,'(A,A)') & ' var ee lev min ', & 'imin jmin max imax jmax mean ' ENDIF ! loop over all constant variables that should be written ! ------------------------------------------------------- #ifdef MESSY CALL int2str(str,iout) chname = 'COSMOc'//str channeli => COSMOOUT DO IF (.NOT. ASSOCIATED(channeli)) THEN write (0,*) 'COSMO-OUTPUT not ASSOCIATED c '//str CALL model_abort (my_cart_id, 3333, ' channel not associated', 'init_output') ENDIF IF (TRIM(chname) == TRIM(channeli%this%label)) EXIT channele => channeli channeli => channeli%next END DO #endif nzrecords = 0 DO n = 1, now%nyvar_c ! location in the variable table i1 = now%ilist_c(1,n) i2 = now%ilist_c(2,n) i3 = now%ilist_c(3,n) ! are we writing tiles or not? IF (var(i1,i2,i3)%ltiles) THEN IF (now%lwrite_tiles) THEN nend_tile = ntiles ELSE nend_tile = 0 ENDIF ELSE nend_tile = 0 ENDIF #ifdef MESSY zvarlev(1:,1:,1:,0:) => channeli%this%vars(n)%ptr(:,:,:,:) #endif IF (izdebug >= 5) THEN WRITE (*,'(3a,i4,a)') ' src_output: processing ', & TRIM(ADJUSTL(var(i1,i2,i3)%name)),' on PE ',my_cart_id,' ...' END IF SELECT CASE (var(i1,i2,i3)%rank) ! Also with tile approach, rank 4/5 should not appear for constant data CASE(3) IF (var(i1,i2,i3)%ltiles) THEN ! this is a 2D variable with tiles kbot = 1 ktop = 1 zvarlev (:,:,1,0:nend_tile) = var(i1,i2,i3)%p3(:,:,0:nend_tile) ELSE ! this is a 3D variable kbot = LBOUND(var(i1,i2,i3)%p3,3) ktop = UBOUND(var(i1,i2,i3)%p3,3) zvarlev(:,:,kbot:ktop,0) = var(i1,i2,i3)%p3(:,:,kbot:ktop) ENDIF DO ntls = 0, nend_tile DO k=kbot,ktop nzrecords = nzrecords + 1 IF (var(i1,i2,i3)%ltiles .AND. now%lwrite_tiles) THEN izaee = ntls ELSE izaee = 0 ENDIF CALL output_data (nuedat, nzrecords, i1,i2,i3, k, ktop, izaee, & zvarlev(1:ie,1:je,k,ntls), now, .FALSE., 'c', 0.0_wp, & .FALSE., ivar_id(n), n, iorg_data, izdebug) ENDDO ENDDO CASE(2) IF (now%yvarc(n)(1:LEN_TRIM(now%yvarc(n))) == 'FIS' ) THEN zvarlev(1:ie,1:je,1,0) = hsurf(1:ie,1:je) * g ELSE zvarlev(1:ie,1:je,1,0) = var(i1,i2,i3)%p2(1:ie,1:je) ENDIF nzrecords = nzrecords+1 izaee = 0 CALL output_data (nuedat, nzrecords, i1,i2,i3, 1, 1, izaee, & zvarlev(:,:,1,0), now, .FALSE., 'c', 0.0_wp, .FALSE., & ivar_id(n), n, iorg_data, izdebug) END SELECT ENDDO #ifdef MESSY IF (L_BM_ORIG_OUTPUT) THEN #endif ! Flush the output buffers and close the file ! ------------------------------------------- CALL output_data (nuedat, -1, -1,-1,-1, -1, -1, 0, & zvarlev(:,:,1,0), now, .TRUE., 'c', 0.0_wp, .FALSE., -1, & -1, iorg_data, izdebug) IF ((now%yform_write /= 'ncdf' .AND. now%yform_write /= 'nc-4') & .OR. nc_asyn_io < 1) THEN CALL close_file (nuedat, now%yform_write, icomm_cart, my_cart_id, & num_compute, lasync_io, yname, llockfiles, idbg_level, & yzerrmsg, izerror) IF (izerror /= 0) THEN CALL model_abort (my_cart_id, 2032, yzerrmsg, yzroutine) ENDIF ENDIF IF (now%yform_write == 'bina') THEN ! release the unit-number again CALL release_unit (nuedat) ENDIF #ifdef MESSY ENDIF #endif ! Indicate that a ready file is needed ! ------------------------------------ lzwrite_ended = .TRUE. ! Write a blank line to YUCHKDAT IF ( (now%lcheck) .AND. (my_cart_id == 0) ) THEN WRITE (nuchkdat,'(A)') ' ' WRITE (nuchkdat,'(A)') ' ' ENDIF cur_gribout_idx = cur_gribout_idx+1 ENDIF ! close file nuchkdat IF ( (now%lcheck) .AND. (my_cart_id == 0) ) THEN CLOSE (nuchkdat, STATUS='KEEP') ENDIF IF (ASSOCIATED(now%next)) THEN now => now%next ELSE EXIT gribout_loop ENDIF ENDDO gribout_loop !------------------------------------------------------------------------------ ! Section 5: Check for further output in step 0 !------------------------------------------------------------------------------ IF ( (my_cart_id == 0) .AND. (lzwrite_ended) ) THEN now => root gribout_loop_2: DO IF (now%ngrib(now%nextstep) == 0) THEN ! further output will be written: no ready file is necessary here lzwrite_ended = .FALSE. ENDIF ! Add optional suffix to filename IF ( LEN_TRIM(now%ysuffix) /= 0 ) THEN yname = yname(1:LEN_TRIM(yname)) // TRIM(now%ysuffix) ENDIF IF (ASSOCIATED(now%next)) THEN now => now%next ELSE EXIT gribout_loop_2 ENDIF ENDDO gribout_loop_2 ! Write ready-file, if required IF (lzwrite_ended) THEN ! Write a blank line to YUCHKDAT IF (izdebug > 10) & WRITE (*,*) "proc ", my_cart_id, ": Enter write_ready." IF (LEN_TRIM(ytrans_out) > 0) THEN ! Create the filename LMF_forecasttime yzhead = 'LMF' CALL make_fn (yzhead, yakdat1, ydate_ini,'f',' ', ntstep, dt, .TRUE., & itype_calendar, ytrans_out, yname, .TRUE., izdebug, izerrstat) ! Write the file OPEN (ntrans_out, FILE=yname, FORM='FORMATTED') WRITE (ntrans_out, '(A)') 'ready' CLOSE (ntrans_out) ENDIF ENDIF ENDIF ! Deallocate arrays for IO DEALLOCATE (iblock, ibmap, ds_real, ds_grib, dsup, ymessage) IF (izdebug > 5) THEN WRITE (*,'(A)') ' src_output: initialization of output ended' ENDIF !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE init_output !============================================================================== !+ Module procedure in src_output for organizing the output !------------------------------------------------------------------------------ SUBROUTINE organize_output (outblock, yextension, numlist, ylist, ilist, & lcout, iout) !------------------------------------------------------------------------------ ! ! Description: ! The routine organize_output is called for every namelist output group and ! for every of the three output lists (model variables, pressure level ! variables and height level variables). In case of pressure level variables ! or height level variables the routines p_int and z_int, resp., are called ! for vertical interpolation. ! ! Parallelization for the output is by layers that should be written ! to the grib file. Every PE gets a layer and packs it into grib format ! (in routine output_data). ! ! Note on the GPU implementation (OpenACC) : every computation on GPU until ! call to output_data. The data is then copied to the CPU and computation are ! run on the CPU (e.g. smooth_pmsl, smooth_geopot) ! ! Method: ! - Initializations (for the grib library) ! - Opening the output grib file ! - Scanning through the list (loop over all variables) ! - Closing the output grib file ! ! Output files: ! Output grib files for model variables (without extension), for ! pressure level variables (with extension 'p') and for height level ! variables (with extension 'z'). ! !------------------------------------------------------------------------------ ! Subroutine / Function arguments TYPE(pp_nl), INTENT(IN) :: & outblock ! pointer to the namelist group ! Scalar arguments with intent(in): CHARACTER (LEN=1), INTENT(IN) :: & yextension ! indicates model variables (''), p-('p') or z-levels ('z') INTEGER, INTENT(IN) :: & numlist ! number of elements in ylist CHARACTER (LEN=clen), INTENT(IN) :: & ylist(numlist) ! list of variables for output INTEGER, INTENT(IN) :: & ilist(3,numlist) ! number of elements in ylist ! The following variables are only meaningful for COSMO/MESSy ! However, for easier code reading they are always defined LOGICAL , INTENT(IN) :: & lcout ! output required for COSMO (not necessarily for CHANNEL) INTEGER , INTENT(IN), OPTIONAL :: & iout ! number of output namelist gribout !------------------------------------------------------------------------------ ! ! Local scalars: INTEGER :: i1,i2,i3, i,j,k, n, ktop, kbot, nentry, ntls, & izaee, isens, iorg_data(4,0:num_compute-1), & ksynmsg, nend_tile INTEGER :: klev, nuedat, niostat, ierrstat, izlen, nzrecords CHARACTER (LEN=250) :: yname CHARACTER (LEN= 25) :: yroutine CHARACTER (LEN= 255) :: yerrmsg CHARACTER (LEN= 14) :: yzdat1 CHARACTER (LEN= 28) :: yzdat2 ! Local arrays: REAL (KIND=wp) :: & #ifndef MESSY zvarlev (ie,je,0:noutlevels,0:ntiles),&! variable for vertical interpolation #endif slev (0:noutlevels) ! stores the z- or the p-levels #ifdef MESSY REAL(KIND=wp), DIMENSION(:,:,:,:), POINTER :: zvarlev => NULL() #endif REAL (KIND=wp) :: & ! zenith_t (ie,je), & ! Arrays for computing the zenith total (dry, zenith_w (ie,je), & ! hydrostatic) delay zenith_h (ie,je), & ! zcape_mu (ie,je), & ! Arrays for most unstable CAPE zcin_mu (ie,je), & ! ... and CIN zcape_ml (ie,je), & ! Arrays for mixed layer CAPE zcin_ml (ie,je), & ! ... and CIN zcape_3km(ie,je), & ! ... and CAPE 3KM zlcl_ml (ie,je), & ! ... and LCL zlfc_ml (ie,je), & ! ... and LFC zhelp2d (ie,je), & ! zrlatdeg (ie,je), & ! zrlondeg (ie,je), & ! zgsp (ie,je), & ! pdot (ie,je,ke), & ! Array for gpu version of LPI zbrn (ie,je,ke), & ! Array for Bulk Richardson Number zhelp1(ie,je,ke), & ! zhelp2(ie,je,ke), & ! zhelp3(ie,je,ke), & ! zhelp4(ie,je,ke), & ! zpres (ie,je,ke), & ! zuspdd(ie,je,ke), & ! u and v in geographical grid to compute zvspdd(ie,je,ke) ! wind speed and wind direction REAL (KIND=wp), PARAMETER :: & ! missing_value = -999.9_wp REAL (KIND=wp) :: & ! zacthour REAL (KIND=wp) :: & zh_bot, zh_top ! bottom and top height of height layer LOGICAL :: & lzenith, & ! indicates whether to compute zenith delay lzrestart, & ! indicates whether restart-files are written lconvind_mu, & ! indicates whether CAPE_MU/CIN_MU has been computed lconvind_ml, & ! indicates whether CAPE_ML/CIN_ML has been computed l_brn, & ! indicates whether BULK RICHARDSON NUMBER has been computed lwarn, & ! to indicate whether a SR issues some warnings l_calc_sdi_already_comp ! prevents from a double computing of Subr. 'calc_sdi' INTEGER :: kzdims(24) INTEGER :: & ivar_id(nzmxid), & ! NetCDF-ID of each variable in the output list nzjulianday, izvctype_write, izdebug, izerror, nzbytes, ipe_out, kspdd CHARACTER (LEN=3) :: & yzhead ! characterizes the special kind of the data #ifdef COSMOART LOGICAL :: & l_ash_massc ! flag to mark if ash_massc is already calculated INTEGER :: & isp ! loop index for number of volcanic ash species INTEGER :: & zmaxloc(ke) ! array to save vertical index of maximum REAL (KIND=wp) :: & zash_massc(ie,je,ke) ! calculated mass concentration of volcanic ash LOGICAL :: & zash_massc_mask(ke) ! mask for calculated mass concentration of volcanic ash REAL (KIND=wp) :: & ztc_factor(ie,je,ke) ! factor for calculation of total column of volcanic ash REAL (KIND=wp) :: & zpres_bot, zpres_top ! bottom and top pressures of pressure layer #endif #ifdef MESSY TYPE(cosmo_output_list), POINTER :: channeli TYPE(cosmo_output_list), POINTER :: channele CHARACTER(LEN=9) :: chname CHARACTER(LEN=3) :: str CHARACTER(LEN=1) :: tag REAL(KIND=wp) :: dummy(ie,je) INTEGER :: ix #endif !- End of header !============================================================================== !------------------------------------------------------------------------------ ! Section 1a: Initializations !------------------------------------------------------------------------------ !$acc enter data create( zvarlev, zbrn, zhelp1, zhelp2, zhelp3, zhelp4, & !$acc zhelp2d, zpres, zcape_mu, zcin_mu, zcape_ml, & !$acc zcin_ml, zlcl_ml, zlfc_ml, zcape_3km, zgsp, & !$acc zenith_t, zenith_h, zenith_w, zrlatdeg, zrlondeg, & !$acc pdot, zuspdd, zvspdd) & !$acc copyin( dzeta_dlam, dzeta_dphi, wgtfac ) yroutine(:) = ' ' yroutine = 'organize_output' ierrstat = 0 izerror = 0 lzenith = .FALSE. lconvind_mu = .FALSE. lconvind_ml = .FALSE. l_brn = .FALSE. lwarn = .FALSE. l_calc_sdi_already_comp = .FALSE. #ifdef COSMOART l_ash_massc = .FALSE. #endif IF (numlist == 0) RETURN #ifdef MESSY ivar_id(:) = 0.0_wp zbrn(:,:,:) = 0.0_wp l_COSMO_now = lcout .AND. L_BM_ORIG_OUTPUT IF (.NOT. L_FORCE_calcout) THEN ! output calculations required for channel IF (.NOT. l_COSMO_now) THEN ! no COSMO output SELECT CASE (yextension) ! test if output for this channel required CASE (' ') IF (js_COSMOm(iout) > 0) THEN ! CHANNEL exists IF (.NOT. LOUTPUT_NOW(js_COSMOm(iout))) RETURN ! no output ! required for present step => RETURN ENDIF CASE ('p') IF (js_COSMOp(iout) > 0) THEN IF (.NOT. LOUTPUT_NOW(js_COSMOp(iout))) RETURN ENDIF CASE ('z') IF (js_COSMOz(iout) > 0) THEN IF (.NOT. LOUTPUT_NOW(js_COSMOz(iout))) RETURN ENDIF CASE ('s') IF (js_COSMOs(iout) > 0) THEN IF (.NOT. LOUTPUT_NOW(js_COSMOs(iout))) RETURN ENDIF CASE ('c') IF (js_COSMOc(iout) > 0) THEN IF (.NOT. LOUTPUT_NOW(js_COSMOc(iout))) RETURN ENDIF END SELECT ELSE ! COSMO output required ! NOTHING TODO ENDIF ENDIF IF (yextension == ' ') THEN tag = 'm' ELSE tag = yextension ENDIF IF (PRESENT(IOUT)) THEN CALL int2str(str,iout) chname = 'COSMO'//tag//str ELSE chname = 'COSMO'//tag ENDIF channeli => COSMOOUT ix = 0 DO IF (.NOT. ASSOCIATED(channeli)) THEN write (0,*) 'COSMO-OUTPUT not ASSOCIATED ', ix, 'X',chname,'X' CALL model_abort (my_cart_id, 3333, yerrmsg, yroutine) ENDIF IF (TRIM(chname) == TRIM(channeli%this%label)) EXIT channele => channeli channeli => channeli%next ix = ix +1 END DO #endif ! Initialize, whether additional debug output shall be done IF (ldebug_io) THEN IF (lprintdeb_all) THEN izdebug = idbg_level ELSE IF (my_cart_id == 0) THEN izdebug = idbg_level ELSE izdebug = 0 ENDIF ENDIF ELSE izdebug = 0 ENDIF IF ((yextension == 'o') .OR. (yextension == 'n')) THEN lzrestart = .TRUE. ELSE lzrestart = .FALSE. ENDIF ! Set lfd, lds and lbm lds = ie_tot * je_tot lbm = 1875 nzbytes = 8 lfd = compute_grib_intbuffer_length(ie_tot, je_tot, nzbytes, iwlength) lfa = compute_grib_intbuffer_length(ie_tot, je_tot, nzbytes, 1) ! gives length in bytes ! Initializations for the grib library ! moving arraydimensions into idims ! declaration dimensions idims_out( 7) = outblock%ie_out_tot * outblock%je_out_tot ! real dimensions idims_out(15) = outblock%ie_out_tot * outblock%je_out_tot idims_out(17) = outblock%ie_out_tot * outblock%je_out_tot ! Allocate GRIB arrays ALLOCATE (iblock(lfd), ibmap(lbm), STAT=ierrstat) ALLOCATE (ds_real(lds), ds_grib(lds), dsup(ndsup) , STAT=ierrstat) ALLOCATE (ymessage(lfa), STAT=ierrstat) slev(:) = 0.0_wp ! gridpoints, simple packing, floating point data ibds(2) = 0 ! nrbit, number of bits ibds(5) = outblock%nrbit ! no bitmap ibms(3) = -2 ! determine the timelevel for output IF (lzrestart) THEN IF (yextension == 'o') THEN IF (.NOT. l2tls) THEN itimelevel = nnow ! for leapfrog #ifdef STATIC_FIELDS trcr_itl = t_nnow ! um_ak_20150115 #endif ELSE itimelevel = nnew ! for Runge-Kutta #ifdef STATIC_FIELDS trcr_itl = t_nnew ! um_ak_20150115 #endif ENDIF ELSEIF (yextension == 'n') THEN itimelevel = nnew #ifdef STATIC_FIELDS trcr_itl = t_nnew ! um_ak_20150115 #endif ENDIF ELSE ! use nnow for output (this was nnew before) itimelevel = nnow #ifdef STATIC_FIELDS trcr_itl = t_nnow ! um_ak_20150115 #endif ENDIF ! Initialization for ivar_id (should be set also for non netcdf output) ivar_id(:) = 0 !------------------------------------------------------------------------------ ! Section 1b: Gather hsurf field to all PEs, if necessary !------------------------------------------------------------------------------ IF (outblock%l_fi_pmsl_smooth) THEN !note OpenACC: this field is only used on CPU in output_data ALLOCATE (hsurf_tot(ie_tot,je_tot), STAT=ierrstat) IF (num_compute > 1) THEN CALL gather_field (hsurf, ie,je, hsurf_tot, ie_tot,je_tot, -1, ierrstat) ELSE hsurf_tot(:,:) = hsurf(:,:) ENDIF ENDIF !------------------------------------------------------------------------------ ! Section 2: Open the grib file !------------------------------------------------------------------------------ ! creating filename IF (outblock%lanalysis) THEN yzhead = 'la'//outblock%ydomain ELSE IF (lzrestart) THEN yzhead = 'lr'//outblock%ydomain ELSE yzhead = 'lf'//outblock%ydomain ENDIF ENDIF IF ((outblock%yform_write == 'bina' .OR. outblock%yform_write == 'ncdf' & .OR. outblock%yform_write == 'nc-4') & .AND. (yextension == 'o' .OR. yextension == 'n')) THEN ! The date of the next time step has to be determined to get the proper ! file name also for ytunit='d' CALL get_utc_date(ntstep+1, ydate_ini, dt, itype_calendar, yzdat1, & yzdat2, nzjulianday, zacthour) CALL make_fn (yzhead, yzdat1, ydate_ini, outblock%ytunit, yextension, & ntstep+1, dt, outblock%lhour, itype_calendar, & outblock%ydir_restart_out, yname, lmmss, izdebug, ierrstat) ELSE IF (izdebug > 10) THEN PRINT *, ' calling make_fn with date/unit: ', yakdat1, ' ', outblock%ytunit ENDIF CALL make_fn (yzhead, yakdat1, ydate_ini, outblock%ytunit, yextension, & ntstep, dt, outblock%lhour, itype_calendar, & outblock%ydir, yname, lmmss, izdebug, ierrstat) ENDIF ! In case of netcdf, add extension '.nc' to filename IF (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4') THEN yname = yname(1:LEN_TRIM(yname)) // '.nc' ENDIF ! Add optional suffix to filename IF ( LEN_TRIM(outblock%ysuffix) /= 0 ) THEN yname = yname(1:LEN_TRIM(yname)) // TRIM(outblock%ysuffix) ENDIF IF (outblock%yform_write == 'bina') THEN ! get a free unit-number for Fortran OPEN CALL get_free_unit (nuedat) ENDIF #ifdef MESSY IF (l_COSMO_now .AND. L_BM_ORIG_OUTPUT) THEN #endif IF ((outblock%yform_write /= 'ncdf' .AND. outblock%yform_write /= 'nc-4') & .OR. nc_asyn_io < 1 .OR. (nc_asyn_io > 0 .AND. lzrestart)) THEN CALL open_file (nuedat, ymode_write, TRIM(outblock%yform_write), & icomm_cart, my_cart_id, num_compute, lasync_io, yname, & llockfiles, idbg_level, yerrmsg, ierrstat) IF (ierrstat /= 0) THEN CALL model_abort (my_cart_id, 2033, yerrmsg, yroutine) ENDIF ENDIF IF ( (outblock%yform_write == 'bina') .AND. (my_cart_id == 0) .AND. (yextension == 'o')) THEN ! write the initial values for the meanvalues and the tke time level WRITE (nuedat,IOSTAT=niostat) psm0, dsem0, msem0, kem0, qcm0, ntke ! write the vertical coordinate parameters IF (refatm%irefatm == 1) THEN izvctype_write = vcoord%ivctype IF (vcoord%ivctype == 1) THEN WRITE (nuedat,IOSTAT=niostat) izvctype_write, refatm%p0sl, refatm%t0sl, & refatm%dt0lp, vcoord%vcflat, vcoord%sigm_coord ELSEIF ( ANY( vcoord%ivctype == (/2,3,4/) ) ) THEN WRITE (nuedat,IOSTAT=niostat) izvctype_write, refatm%p0sl, refatm%t0sl, & refatm%dt0lp, vcoord%vcflat, vcoord%vert_coord ENDIF ELSEIF (refatm%irefatm == 2) THEN izvctype_write = vcoord%ivctype+100 IF (vcoord%ivctype == 1) THEN WRITE (nuedat,IOSTAT=niostat) izvctype_write, refatm%p0sl, refatm%t0sl, & refatm%dt0lp, vcoord%vcflat, vcoord%sigm_coord ELSEIF ( ANY( vcoord%ivctype == (/2,3,4/) ) ) THEN WRITE (nuedat,IOSTAT=niostat) izvctype_write, refatm%p0sl, refatm%t0sl, & refatm%dt0lp, vcoord%vcflat, vcoord%vert_coord ENDIF WRITE (nuedat,IOSTAT=niostat) refatm%delta_t, refatm%h_scal ELSEIF (refatm%irefatm == 3) THEN izvctype_write = vcoord%ivctype+200 IF (vcoord%ivctype == 1) THEN WRITE (nuedat,IOSTAT=niostat) izvctype_write, refatm%p0sl, refatm%t0sl, & refatm%dt0lp, vcoord%vcflat, vcoord%sigm_coord ELSEIF ( ANY( vcoord%ivctype == (/2,3,4/) ) ) THEN WRITE (nuedat,IOSTAT=niostat) izvctype_write, refatm%p0sl, refatm%t0sl, & refatm%dt0lp, vcoord%vcflat, vcoord%vert_coord ENDIF WRITE (nuedat,IOSTAT=niostat) refatm%bvref ENDIF #ifdef EULAG IF (leulag) THEN WRITE (nuedat,IOSTAT=niostat) REAL(st, KIND=wp) WRITE (nuedat,IOSTAT=niostat) REAL(epp1, KIND=wp) ENDIF #endif ENDIF #ifdef NETCDF IF (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4') THEN ! .. Adjustments to some meta data of output records, depending on the model configuration: adj_loop: DO n = 1, numlist ! indices of field in variable table i1 = ilist(1,n) i2 = ilist(2,n) i3 = ilist(3,n) #ifdef RADARFWO ! .. Adjust the long names of DBZ-values according to the ! actual dBZ-configuration: IF (TRIM(ylist(n)) == 'DBZ') THEN SELECT CASE (outblock%dbz%itype_refl) CASE (1) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Mie Scattering' CASE (2) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh approximation' CASE (3) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi approximation' CASE (4) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi (dry) approximation' END SELECT ELSEIF (TRIM(ylist(n)) == 'DBZ_850') THEN SELECT CASE (outblock%dbz%itype_refl) CASE (1) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Mie Scattering in 850 hPa' CASE (2) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh approximation in 850 hPa' CASE (3) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi approximation in 850 hPa' CASE (4) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi (dry) approximation in 850 hPa' END SELECT ELSEIF (TRIM(ylist(n)) == 'DBZ_CMAX') THEN SELECT CASE (outblock%dbz%itype_refl) CASE (1) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Mie Scattering column max' CASE (2) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh approximation column max' CASE (3) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi approximation column max' CASE (4) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi (dry) approximation column max' END SELECT ELSEIF (TRIM(ylist(n)) == 'DBZ_CTMAX') THEN SELECT CASE (outblock%dbz%itype_refl) CASE (1) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Mie Scattering column and time max' CASE (2) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh approximation column and time max' CASE (3) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi approximation column and time max' CASE (4) var(i1,i2,i3)%long_name = 'unatt. radar reflectivity Rayleigh-Oguchi (dry) approximation column and time max' END SELECT ELSEIF ( & #else IF ( & #endif ( TRIM(ylist(n)) == 'QC' .OR. TRIM(ylist(n)) == 'NCCLOUD' .OR. & TRIM(ylist(n)) == 'QI' .OR. TRIM(ylist(n)) == 'NCICE' .OR. & TRIM(ylist(n)) == 'QG' .OR. TRIM(ylist(n)) == 'NCGRAUPEL' .OR. & TRIM(ylist(n)) == 'QR' .OR. TRIM(ylist(n)) == 'NCRAIN' .OR. & TRIM(ylist(n)) == 'QS' .OR. TRIM(ylist(n)) == 'NCSNOW' .OR. & TRIM(ylist(n)) == 'QH' .OR. TRIM(ylist(n)) == 'NCHAIL' .OR. & TRIM(ylist(n)) == 'QRS' .OR. TRIM(ylist(n)) == 'Q_SEDIM' ) & ) THEN ! Output of cloud microphysics variables either as densities or mass specific: ! (the default unit is 'kg kg-1' or '1') IF (ylist(n)(1:2) == 'NC') THEN IF (outblock%loutput_q_densities) THEN var(i1,i2,i3)%units = 'm-3' ELSE var(i1,i2,i3)%units = 'kg-1' END IF ELSE IF (outblock%loutput_q_densities) THEN var(i1,i2,i3)%units = 'kg m-3' ELSE var(i1,i2,i3)%units = 'kg kg-1' END IF END IF END IF END DO adj_loop END IF #endif #ifdef NETCDF IF ((outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4') & .AND. (nc_asyn_io < 1 .OR. lzrestart)) THEN ! Write global headers for netcdf file ! IF ((yextension == 'o') .OR. (yextension == 'n')) THEN IF (lzrestart .AND. (wp==dp)) THEN CALL write_nc_gdefs (nuedat, outblock, icomm_cart, num_compute, & yextension, NF90_DOUBLE, -1, yerrmsg, ierrstat) ELSE CALL write_nc_gdefs (nuedat, outblock, icomm_cart, num_compute, & yextension, NF90_FLOAT, -1, yerrmsg, ierrstat) ENDIF IF (ierrstat /= 0) THEN CALL model_abort (my_cart_id, 8052, yerrmsg, yroutine) ENDIF ! IF ((yextension == 'o') .OR. (yextension == 'n')) THEN IF (lzrestart .AND. (wp==dp)) THEN CALL write_nc_vdefs (nuedat, numlist, ilist, ivar_id, & outblock%luvmasspoint, outblock%lwrite_tiles, & outblock%lcompress_netcdf, & icomm_cart, num_compute, yextension, NF90_DOUBLE,& yerrmsg, ierrstat) ELSE CALL write_nc_vdefs (nuedat, numlist, ilist, ivar_id, & outblock%luvmasspoint, outblock%lwrite_tiles, & outblock%lcompress_netcdf, & icomm_cart, num_compute, yextension, NF90_FLOAT, & yerrmsg, ierrstat) ENDIF IF (ierrstat /= 0) THEN CALL model_abort (my_cart_id, 8053, yerrmsg, yroutine) ENDIF ENDIF #endif #ifdef MESSY ENDIF #endif ! Write the headline in YUCHKDAT for this file IF ( (outblock%lcheck) .AND. (my_cart_id == 0) ) THEN OPEN(nuchkdat, FILE=yuchkdat, FORM= 'FORMATTED', STATUS='UNKNOWN', & POSITION='APPEND', IOSTAT=niostat) IF(niostat /= 0) THEN yerrmsg = ' ERROR *** Error while opening file YUCHKDAT *** ' ierrstat = 2005 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF WRITE (nuchkdat,'(A,I7)') & 'Check the data in output file for step: ', ntstep WRITE (nuchkdat,'(A,A)') & ' File: ',TRIM(yname) WRITE (nuchkdat,'(A,I5,A,I5,A,I5)') & ' ie_tot =',ie_tot,' je_tot =',je_tot,' ke_tot =',ke_tot WRITE (nuchkdat,'(A)') ' ' WRITE (nuchkdat,'(A,A)') & ' var ee lev min ', & 'imin jmin max imax jmax mean ' ENDIF !------------------------------------------------------------------------------ ! Section 3: Look for output variables in LM variable table !------------------------------------------------------------------------------ !---------------------------------------------------------------------------- ! 3.1. Retrieve the required microphysics tracers !---------------------------------------------------------------------------- ! Always existing tracers CALL trcr_get(izerror, idt_qv, ptr_tlev = itimelevel, ptr = qv) IF (izerror /= 0) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qc, ptr_tlev = itimelevel, ptr = qc) IF (izerror /= 0) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF ! Conditionally existing tracers CALL trcr_get(izerror, idt_qi, ptr_tlev = itimelevel, ptr = qi) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qr, ptr_tlev = itimelevel, ptr = qr) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, & yroutine) ENDIF CALL trcr_get(izerror, idt_qs, ptr_tlev = itimelevel, ptr = qs) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qg, ptr_tlev = itimelevel, ptr = qg) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF #if defined TWOMOM_SB || defined CLOUDRAD CALL trcr_get(izerror, idt_qnc, ptr_tlev = itimelevel, ptr = qnc) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF #endif #ifdef CLOUDRAD CALL trcr_get(izerror, idt_ncn, ptr_tlev = itimelevel, ptr = ncn) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF #endif #ifdef TWOMOM_SB IF (itype_gscp >= 100) THEN ! Tracers for the 2-moment scheme CALL trcr_get(izerror, idt_qh, ptr_tlev = itimelevel, ptr = qh) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qnc, ptr_tlev = itimelevel, ptr = qnc) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qnr, ptr_tlev = itimelevel, ptr = qnr) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qni, ptr_tlev = itimelevel, ptr = qni) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qns, ptr_tlev = itimelevel, ptr = qns) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qng, ptr_tlev = itimelevel, ptr = qng) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF CALL trcr_get(izerror, idt_qnh, ptr_tlev = itimelevel, ptr = qnh) IF (izerror /= 0 .AND. izerror /= T_ERR_NOTFOUND) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF ENDIF #endif #ifdef COSMOART IF (l_cosmo_art.and.lvolcano) THEN CALL trcr_get_block(izerror, idx_start=trcr_idx_ash(1), idx_end=trcr_idx_ash(isp_ash), & ptr_tlev = itimelevel, ptr = cash) IF (izerror /= 0) THEN yerrmsg = trcr_errorstr(izerror) CALL model_abort(my_cart_id, izerror, yerrmsg, yroutine) ENDIF ENDIF #endif ! Re-compute qrs and rho for output timelevel itimelevel ! (in the long term storage they are only available on timelevel nnew) ALLOCATE ( zrho_itl (ie,je,ke), zqrs_itl (ie,je,ke), stat=izerror ) ALLOCATE ( zqc_itl(ie,je,ke), zqr_itl(ie,je,ke), zqs_itl(ie,je,ke), & zqi_itl(ie,je,ke), zqg_itl(ie,je,ke), stat=izerror ) ! storage for OpenACC array !$acc enter data create( zrho_itl, zqrs_itl, zqc_itl, zqr_itl, zqs_itl, & !$acc zqi_itl, zqg_itl ) #ifdef TWOMOM_SB IF (itype_gscp >= 100) THEN ALLOCATE ( zqh_itl(ie,je,ke), zqnc_itl(ie,je,ke), zqnr_itl(ie,je,ke), & zqni_itl(ie,je,ke), zqns_itl(ie,je,ke), zqng_itl(ie,je,ke), zqnh_itl(ie,je,ke), & stat=izerror ) ENDIF #endif IF ( izerror /= 0 ) THEN CALL model_abort (my_cart_id, 90034, 'Error allocating zrho_itl, zqrs_itl', yroutine) END IF ! Sum up qrs for the output timelevel: !$acc data present(zqrs_itl, qr) !$acc parallel !$acc loop gang vector collapse(3) DO k = 1,ke DO j = 1,je DO i = 1,ie zqrs_itl(i,j,k) = qr(i,j,k) END DO END DO END DO !$acc end parallel !$acc end data IF (ASSOCIATED(qi)) THEN !$acc data present(zqrs_itl, qi) !$acc parallel !$acc loop gang vector collapse(3) DO k = 1,ke DO j = 1,je DO i = 1,ie zqrs_itl(i,j,k) = zqrs_itl(i,j,k) + qi(i,j,k) END DO END DO END DO !$acc end parallel !$acc end data ENDIF IF ( ASSOCIATED(qs) ) THEN !$acc data present(zqrs_itl, qs) !$acc parallel !$acc loop gang vector collapse(3) DO k = 1,ke DO j = 1,je DO i = 1,ie zqrs_itl(i,j,k) = zqrs_itl(i,j,k) + qs(i,j,k) END DO END DO END DO !$acc end parallel !$acc end data END IF IF ( ASSOCIATED(qg) ) THEN !$acc data present(zqrs_itl, qg) !$acc parallel !$acc loop gang vector collapse(3) DO k = 1,ke DO j = 1,je DO i = 1,ie zqrs_itl(i,j,k) = zqrs_itl(i,j,k) + qg(i,j,k) END DO END DO END DO !$acc end parallel !$acc end data END IF #ifdef TWOMOM_SB IF (itype_gscp >= 2000) THEN !$acc data present(zqrs_itl, qh) !$acc parallel DO k = 1,ke !$acc loop gang DO j = 1,je !$acc loop vector DO i = 1,ie zqrs_itl(i,j,k) = zqrs_itl(i,j,k) + qh(i,j,k) END DO END DO END DO !$acc end parallel !$acc end data ENDIF #endif ! Density on the timelevels itimelevel: CALL calrho( t(:,:,:,itimelevel), pp(:,:,:,itimelevel), qv, & qc, zqrs_itl, p0, zrho_itl, ie, je, ke, r_d, & rvd_m_o, lacc=.TRUE. ) !---------------------------------------------------------------------------- ! 3.2. Compute wind speed and direction, if wanted !---------------------------------------------------------------------------- ! is now fully done in near_surface IF (lspdd .OR. lspdd_10m) THEN !$acc kernels present (zrlatdeg, rlat) zrlatdeg(:,:) = rlat(:,:)*raddeg !$acc end kernels !$acc kernels present (zrlondeg, rlon) zrlondeg(:,:) = rlon(:,:)*raddeg !$acc end kernels ENDIF !---------------------------------------------------------------------------- ! 3.3. Copy sfc-save fields back to ijk for restarts !---------------------------------------------------------------------------- IF (lzrestart .AND. lsoil .AND. (wp /= vpp)) THEN CALL sfc_restart_copy_toijk ENDIF !---------------------------------------------------------------------------- ! 3.4. loop over all variables that should be written and loop over all ! variables in the LM variable table until equal elements are found !---------------------------------------------------------------------------- nzrecords = 0 izaee = 0 ! have to modify for tiles write_loop: DO n = 1, numlist ! indices of field in variable table i1 = ilist(1,n) i2 = ilist(2,n) i3 = ilist(3,n) ! are we writing tiles or not? IF (var(i1,i2,i3)%ltiles) THEN IF (outblock%lwrite_tiles) THEN nend_tile = ntiles ELSE nend_tile = 0 ENDIF ELSE nend_tile = 0 ENDIF #ifdef MESSY zvarlev(1:,1:,1:,0:) => channeli%this%vars(n)%ptr(:,:,:,:) #endif ! determine the time level to write izlen = LEN_TRIM(ylist(n)) IF (ylist(n)(1:izlen) == 'TKE' .OR. ylist(n)(1:izlen) == 'TKETENS') THEN IF (itype_turb < 5) THEN itl = ntke ELSE IF (itype_turb >= 5 .AND. itype_turb <= 8 .AND. .NOT. lprog_tke) THEN itl = 1 ELSE itl = itimelevel END IF ELSE itl = itimelevel ENDIF IF ( izdebug >= 5 ) THEN PRINT *, ' src_output: processing ', ylist(n)(1:izlen) ENDIF SELECT CASE (var(i1,i2,i3)%rank) ! pack data depending on the rank CASE(5) IF (yextension == 'p') THEN CALL p_int (outblock, i1,i2,i3, outblock%yvarpl(n), izdebug, zvarlev(:,:,1:outblock%kepin,0)) kbot = 1 ktop = outblock%kepin slev(1:outblock%kepin) = outblock%plev(1:outblock%kepin) nend_tile = 0 ! no tiles will be interpolated ELSEIF (yextension == 'z') THEN CALL z_int (outblock, i1,i2,i3, outblock%yvarzl(n), izdebug, zvarlev(:,:,1:outblock%kezin,0)) kbot = 1 ktop = outblock%kezin slev(1:outblock%kezin) = outblock%zlev(1:outblock%kezin) nend_tile = 0 ! no tiles will be interpolated ELSE ! calculate additional non-global 4-d fields if required IF (ylist(n)(1:izlen) == 'TKE' .AND. (.NOT. lzrestart) ) THEN kbot = 1 ktop = ke+1 SELECT CASE( itype_turb ) CASE( 5:8 ) zvarp5_ptr => var(i1,i2,i3)%p5 !$acc parallel default(present) !$acc loop gang vector collapse(4) DO ntls = 0, nend_tile DO k=kbot,ktop DO j=1,je DO i=1,ie zvarlev(i,j,k,ntls) = zvarp5_ptr(i,j,k,ntls,itl) END DO END DO END DO END DO !$acc end parallel CASE DEFAULT zvarp5_ptr => var(i1,i2,i3)%p5 !$acc parallel default(present) !$acc loop gang vector collapse(4) DO ntls = 0, nend_tile DO k=kbot,ktop DO j=1,je DO i=1,ie zvarlev(i,j,k,ntls) = 0.5_wp * (zvarp5_ptr(i,j,k,ntls,itl))**2 END DO END DO END DO END DO !$acc end parallel END SELECT ELSE ! these are 3D variables with tiles and time dependency ! determine kbot (different for soil temperature depending on NetCDF, GRIB) IF ((ylist(n)(1:izlen) == 'T_SO') .OR. (ylist(n)(1:izlen) == 'T_SNOW_M')) THEN IF (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4') THEN IF (lzrestart) THEN kbot = 0 !this is LBOUND (var(i1,i2,i3)%p5,3) ELSE kbot = 1 !usual ncdf output only writes T_SO (1:ktop) ENDIF ELSE kbot = LBOUND (var(i1,i2,i3)%p5,3) ENDIF ELSE kbot = LBOUND (var(i1,i2,i3)%p5,3) ENDIF ! and determine ktop ktop = UBOUND (var(i1,i2,i3)%p5,3) #ifdef STATIC_FIELDS IF ( var(i1,i2,i3)%lsm == 't') itl=trcr_itl #endif zvarp5_ptr => var(i1,i2,i3)%p5 !$acc parallel default(present) !$acc loop gang vector collapse(4) DO ntls = 0, nend_tile DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,ntls) = zvarp5_ptr(i,j,k,ntls,itl) ENDDO ENDDO ENDDO ENDDO !$acc end parallel ENDIF ENDIF ! p-/z-/m-levels DO ntls = 0, nend_tile izaee = ntls DO k = kbot, ktop nzrecords = nzrecords + 1 IF ((ylist(n)(1:izlen) == 'T_SO') .AND. lzrestart .AND. & (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4')) THEN ! In netcdf, T_SO cannot be written as (0:ke_soil+1), but ! has to be between (1:ke_soil+2) CALL output_data (nuedat, nzrecords, i1,i2,i3, k+1, ktop, izaee, & zvarlev(:,:,k,ntls), outblock, .FALSE., yextension, slev(k), & lzrestart, ivar_id(n), n, iorg_data, izdebug, lacc=.TRUE.) ELSE CALL output_data (nuedat, nzrecords, i1,i2,i3, k, ktop, izaee, & zvarlev(:,:,k,ntls), outblock, .FALSE., yextension, slev(k), & lzrestart, ivar_id(n), n, iorg_data, izdebug, lacc=.TRUE.) ENDIF ENDDO ENDDO CASE(4) ! vertical interpolation, if necessary IF (yextension == 'p') THEN CALL p_int (outblock, i1,i2,i3, outblock%yvarpl(n), izdebug, zvarlev(:,:,1:outblock%kepin,0)) kbot = 1 ktop = outblock%kepin slev(1:outblock%kepin) = outblock%plev(1:outblock%kepin) nend_tile = 0 ! no tiles will be interpolated ELSEIF (yextension == 'z') THEN CALL z_int (outblock, i1,i2,i3, outblock%yvarzl(n), izdebug, zvarlev(:,:,1:outblock%kezin,0)) kbot = 1 ktop = outblock%kezin slev(1:outblock%kezin) = outblock%zlev(1:outblock%kezin) nend_tile = 0 ! no tiles will be interpolated ELSE ! calculate additional non-global 4-d fields if required IF ( ylist(n)(1:izlen) == 'P' ) THEN kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=kbot,ktop DO j=1,je DO i=1,ie zvarlev(i,j,k,0) = p0(i,j,k) + pp(i,j,k,itl) END DO END DO END DO !$acc end parallel ELSEIF ( (ylist(n)(1:izlen) == 'U') .AND. & (outblock%luvmasspoint) .AND. (.NOT. lzrestart) ) THEN ! determine first and last level kbot = LBOUND (var(i1,i2,i3)%p4,3) ktop = UBOUND (var(i1,i2,i3)%p4,3) zvarp4_ptr => var(i1,i2,i3)%p4 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 2, ie zvarlev(i,j,k,0) = 0.5_wp * (zvarp4_ptr(i-1,j,k,itl) + & zvarp4_ptr(i ,j,k,itl)) ENDDO zvarlev(1,j,k,0) = zvarlev(2,j,k,0) ENDDO ENDDO !$acc end parallel ELSEIF ( (ylist(n)(1:izlen) == 'V') .AND. & (outblock%luvmasspoint) .AND. (.NOT. lzrestart) ) THEN ! determine first and last level kbot = LBOUND (var(i1,i2,i3)%p4,3) ktop = UBOUND (var(i1,i2,i3)%p4,3) zvarp4_ptr => var(i1,i2,i3)%p4 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 2, je DO i = 1, ie zvarlev(i,j,k,0) = 0.5_wp * (zvarp4_ptr(i,j-1,k,itl) + & zvarp4_ptr(i,j ,k,itl)) ENDDO ENDDO ENDDO !$acc end parallel !$acc parallel default(present) !$acc loop gang vector collapse(2) DO k = kbot, ktop DO i = 1, ie zvarlev(i,1,k,0) = zvarlev(i,2,k,0) ENDDO ENDDO !$acc end parallel ELSEIF ((.NOT. lzrestart) .AND. & ( ylist(n)(1:izlen) == 'QC' .OR. ylist(n)(1:izlen) == 'NCCLOUD' .OR. & ylist(n)(1:izlen) == 'QI' .OR. ylist(n)(1:izlen) == 'NCICE' .OR. & ylist(n)(1:izlen) == 'QG' .OR. ylist(n)(1:izlen) == 'NCGRAUPEL' .OR. & ylist(n)(1:izlen) == 'QR' .OR. ylist(n)(1:izlen) == 'NCRAIN' .OR. & ylist(n)(1:izlen) == 'QS' .OR. ylist(n)(1:izlen) == 'NCSNOW' .OR. & ylist(n)(1:izlen) == 'QH' .OR. ylist(n)(1:izlen) == 'NCHAIL') ) THEN ! Output of cloud microphysics variables either as densities or mass specific: #ifdef STATIC_FIELDS itl = trcr_itl #endif ! determine first and last level kbot = LBOUND (var(i1,i2,i3)%p4,3) ktop = UBOUND (var(i1,i2,i3)%p4,3) IF (outblock%loutput_q_densities) THEN ! output as densities: zvarp4_ptr => var(i1,i2,i3)%p4 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp4_ptr(i,j,k,itl) * zrho_itl(i,j,k) ENDDO ENDDO ENDDO !$acc end parallel ELSE ! output as mass specific: zvarp4_ptr => var(i1,i2,i3)%p4 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp4_ptr(i,j,k,itl) ENDDO ENDDO ENDDO !$acc end parallel ENDIF ELSEIF (ylist(n)(1:izlen)=='WSOIL_FLX' .OR. ylist(n)(1:izlen)=='Q_ROFF') THEN kbot = 1 ktop = ibot_w_so ! ke_soil_hy zvarp4_ptr => var(i1,i2,i3)%p4 !$acc parallel default(present) !$acc loop gang vector collapse(4) DO ntls = 0, nend_tile DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,ntls) = zvarp4_ptr(i,j,k,ntls) ENDDO ENDDO ENDDO ENDDO !$acc end parallel #ifdef EULAG ELSEIF (ylist(n)(1:izlen)=='U_EULAG' .OR. & ylist(n)(1:izlen)=='V_EULAG' .OR. ylist(n)(1:izlen)=='W_EULAG' .OR. & ylist(n)(1:izlen)=='OX_EULAG'.OR. ylist(n)(1:izlen)=='OY_EULAG' .OR. & ylist(n)(1:izlen)=='OZ_EULAG'.OR. ylist(n)(1:izlen)=='RHO_EULAG') & THEN kbot = 1 ktop = ke zvarlev(istart:iend,jstart:jend,1:ke,0) = var(i1,i2,i3)%p4(1:np,1:mp,lp:1:-1,0) ELSEIF (ylist(n)(1:izlen)=='U_EULAG_EXT'.OR. & ylist(n)(1:izlen)=='V_EULAG_EXT'.OR. & ylist(n)(1:izlen)=='W_EULAG_EXT') THEN kbot = 1 ktop = ke zvarlev(istart:iend,jstart:jend,1:ke,0) = var(i1,i2,i3)%p4(1:np,1:mp,lp:1:-1,1) #endif ELSE #ifdef STATIC_FIELDS IF ( var(i1,i2,i3)%lsm == 't') itl=trcr_itl #endif !US later we will have 2D fields with tile and time dimension: then we have to adapt! !US because the 3rd dimension will then be the tiles! !US or the 3rd dimension is the vertical, and tiles are in the 4th dimension (and there is not time) zvarp4_ptr => var(i1,i2,i3)%p4 IF (var(i1,i2,i3)%ltiles .AND. var(i1,i2,i3)%idimvert <= 1) THEN ! this is a 2D + tiles + time variable ! determine first and last level kbot = 1 ktop = 1 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO ntls = 0, nend_tile DO j = 1, je DO i = 1, ie zvarlev(i,j,1,ntls) = zvarp4_ptr(i,j,ntls,itl) ENDDO ENDDO ENDDO !$acc end parallel ELSEIF (var(i1,i2,i3)%ltiles .AND. var(i1,i2,i3)%idimvert > 1) THEN ! this is a 3D + tiles varialbe ! determine first and last level kbot = LBOUND (var(i1,i2,i3)%p4,3) ktop = UBOUND (var(i1,i2,i3)%p4,3) !$acc parallel default(present) !$acc loop gang vector collapse(4) DO ntls = 0, nend_tile DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,ntls) = zvarp4_ptr(i,j,k,ntls) ENDDO ENDDO ENDDO ENDDO !$acc end parallel ELSE ! this is a 3D + time variable ! determine first and last level kbot = LBOUND (var(i1,i2,i3)%p4,3) ktop = UBOUND (var(i1,i2,i3)%p4,3) !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp4_ptr(i,j,k,itl) ENDDO ENDDO ENDDO !$acc end parallel ENDIF ENDIF ENDIF ! p-/z-/m-levels DO ntls = 0, nend_tile izaee = ntls DO k = kbot, ktop nzrecords = nzrecords + 1 IF ((ylist(n)(1:izlen) == 'T_SO_SAVE') .AND. lzrestart .AND. & (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4')) THEN ! In netcdf, T_SO_SAVE cannot be written as (0:ke_soil+1), but ! has to be between (1:ke_soil+2) CALL output_data (nuedat, nzrecords, i1,i2,i3, k+1, ktop, izaee, & zvarlev(:,:,k,ntls), outblock, .FALSE., yextension, slev(k), & lzrestart, ivar_id(n), n, iorg_data, izdebug, lacc=.TRUE.) ELSE CALL output_data (nuedat, nzrecords, i1,i2,i3, k, ktop, izaee, & zvarlev(:,:,k,ntls), outblock, .FALSE., yextension, slev(k), & lzrestart, ivar_id(n), n, iorg_data, izdebug, lacc=.TRUE.) ENDIF ENDDO ENDDO CASE(3) IF (yextension == 's') THEN #if defined RTTOV7 || defined RTTOV10 || defined RTTOV12 IF (ylist(n)(1:izlen) == 'SYNME7') THEN ! Look for entry in sat_compute nentry = -1 DO isens = 1, num_sensors IF ( (sat_compute(isens)%ysatellite(1:8)=='METEOSAT') .AND. & (sat_compute(isens)%nsat_id == 7 ) .AND. & (sat_compute(isens)%ysensor =='MVIRI' ) ) THEN nentry = isens ENDIF ENDDO kbot = 1 IF (luse_rttov .AND. (nentry > 0)) THEN ktop = UBOUND(synme7,3) !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = synme7(i,j,k) END DO END DO END DO !$acc end parallel slev(:) = REAL(nentry, wp) ELSE ktop = 0 ENDIF ELSEIF (ylist(n)(1:izlen) == 'SYNMSG') THEN ! Look for entry in sat_compute nentry = -1 DO isens = 1, num_sensors IF ( (sat_compute(isens)%ysatellite(1:3)=='MSG' ) .AND. & ((sat_compute(isens)%nsat_id == 1 ) .OR. & (sat_compute(isens)%nsat_id == 2 )) .AND. & (sat_compute(isens)%ysensor =='SEVIRI' ) ) THEN nentry = isens ENDIF ENDDO kbot = 1 IF (luse_rttov .AND. (nentry > 0)) THEN ktop = UBOUND(synmsg,3) !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = synmsg(i,j,k) END DO END DO END DO !$acc end parallel slev(:) = REAL(nentry, wp) ELSE ktop = 0 ENDIF ELSEIF (ylist(n)(1:izlen) == 'MSG_TB') THEN kbot = 1 ktop = nmsgchan ksynmsg = 1 !$acc parallel default(present) !$acc loop seq private( ksynmsg ) DO k = kbot, ktop !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,kbot:ktop,0) = synmsg(i,j,ksynmsg) END DO END DO ksynmsg = ksynmsg + 4 ! 1:29:4 END DO !$acc end parallel DO isens = 1, num_sensors IF ( (sat_compute(isens)%ysatellite(1:3)=='MSG' ) .AND. & ((sat_compute(isens)%nsat_id == 1 ) .OR. & (sat_compute(isens)%nsat_id == 2 )) .AND. & (sat_compute(isens)%ysensor =='SEVIRI' ) ) THEN nentry = isens ENDIF ENDDO slev(:) = REAL(nentry, wp) ELSEIF (ylist(n)(1:izlen) == 'MSG_TBC') THEN kbot = 1 ktop = nmsgchan ksynmsg = 2 !$acc parallel default(present) !$acc loop seq private( ksynmsg ) DO k = kbot, ktop !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = synmsg(i,j,ksynmsg) END DO END DO ksynmsg = ksynmsg + 4 ! 2:30:4 END DO !$acc end parallel DO isens = 1, num_sensors IF ( (sat_compute(isens)%ysatellite(1:3)=='MSG' ) .AND. & ((sat_compute(isens)%nsat_id == 1 ) .OR. & (sat_compute(isens)%nsat_id == 2 )) .AND. & (sat_compute(isens)%ysensor =='SEVIRI' ) ) THEN nentry = isens ENDIF ENDDO slev(:) = REAL(nentry, wp) ELSEIF (ylist(n)(1:izlen) == 'MSG_RAD') THEN kbot = 1 ktop = nmsgchan ksynmsg = 3 !$acc parallel default(present) !$acc loop seq private( ksynmsg ) DO k = kbot, ktop !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = synmsg(i,j,ksynmsg) END DO END DO ksynmsg = ksynmsg + 4 ! 3:31:4 END DO !$acc end parallel DO isens = 1, num_sensors IF ( (sat_compute(isens)%ysatellite(1:3)=='MSG' ) .AND. & ((sat_compute(isens)%nsat_id == 1 ) .OR. & (sat_compute(isens)%nsat_id == 2 )) .AND. & (sat_compute(isens)%ysensor =='SEVIRI' ) ) THEN nentry = isens ENDIF ENDDO slev(:) = REAL(nentry, wp) ELSEIF (ylist(n)(1:izlen) == 'MSG_RADC') THEN kbot = 1 ktop = nmsgchan ksynmsg = 4 !$acc parallel default(present) !$acc loop seq private( ksynmsg ) DO k = kbot, ktop !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = synmsg(i,j,ksynmsg) END DO END DO ksynmsg = ksynmsg + 4 ! 4:32:4 END DO !$acc end parallel DO isens = 1, num_sensors IF ( (sat_compute(isens)%ysatellite(1:3)=='MSG' ) .AND. & ((sat_compute(isens)%nsat_id == 1 ) .OR. & (sat_compute(isens)%nsat_id == 2 )) .AND. & (sat_compute(isens)%ysensor =='SEVIRI' ) ) THEN nentry = isens ENDIF ENDDO slev(:) = REAL(nentry, wp) ENDIF #endif ELSEIF (yextension == 'p') THEN ! vertical interpolation on p-levels, if necessary IF ( ylist(n)(1:izlen) == 'SP') THEN kspdd = outblock%kepin CALL p_int (outblock, 3,33,1, 'U ', izdebug, zuspdd (:,:,1:kspdd)) CALL p_int (outblock, 3,34,1, 'V ', izdebug, zvspdd (:,:,1:kspdd)) DO k = 1, kspdd ! rotate U and V to geographical grid CALL uvrot2uv_vec (zuspdd(:,:,k), zvspdd(:,:,k), zrlatdeg, zrlondeg, & pollat, pollon, ie, je) !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = SQRT (zuspdd(i,j,k)*zuspdd(i,j,k) + zvspdd(i,j,k)*zvspdd(i,j,k)) ENDDO ENDDO !$acc end parallel ENDDO ELSEIF ( ylist(n)(1:izlen) == 'DD') THEN kspdd = outblock%kepin CALL p_int (outblock, 3,33,1, 'U ', izdebug, zuspdd (:,:,1:kspdd)) CALL p_int (outblock, 3,34,1, 'V ', izdebug, zvspdd (:,:,1:kspdd)) DO k = 1, kspdd ! rotate U and V to geographical grid CALL uvrot2uv_vec (zuspdd(:,:,k), zvspdd(:,:,k), zrlatdeg, zrlondeg, & pollat, pollon, ie, je) !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = raddeg * ATAN2 (zuspdd(i,j,k), zvspdd(i,j,k)) + 180.0_wp ENDDO ENDDO !$acc end parallel ENDDO ELSE CALL p_int (outblock, i1,i2,i3, outblock%yvarpl(n), izdebug, zvarlev(:,:,1:outblock%kepin,0)) ENDIF kbot = 1 ktop = outblock%kepin slev(1:outblock%kepin) = outblock%plev(1:outblock%kepin) ELSEIF (yextension == 'z') THEN ! vertical interpolation on z-levels, if necessary IF ( ylist(n)(1:izlen) == 'SP') THEN kspdd = outblock%kezin CALL z_int (outblock, 3,33,1, 'U ', izdebug, zuspdd (:,:,1:kspdd)) CALL z_int (outblock, 3,34,1, 'V ', izdebug, zvspdd (:,:,1:kspdd)) DO k = 1, kspdd ! rotate U and V to geographical grid CALL uvrot2uv_vec (zuspdd(:,:,k), zvspdd(:,:,k), zrlatdeg, zrlondeg, & pollat, pollon, ie, je) !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = SQRT (zuspdd(i,j,k)*zuspdd(i,j,k) + zvspdd(i,j,k)*zvspdd(i,j,k)) ENDDO ENDDO !$acc end parallel ENDDO ELSEIF ( ylist(n)(1:izlen) == 'DD') THEN kspdd = outblock%kezin CALL z_int (outblock, 3,33,1, 'U ', izdebug, zuspdd (:,:,1:kspdd)) CALL z_int (outblock, 3,34,1, 'V ', izdebug, zvspdd (:,:,1:kspdd)) DO k = 1, kspdd ! rotate U and V to geographical grid CALL uvrot2uv_vec (zuspdd(:,:,k), zvspdd(:,:,k), zrlatdeg, zrlondeg, & pollat, pollon, ie, je) !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = raddeg * ATAN2 (zuspdd(i,j,k), zvspdd(i,j,k)) + 180.0_wp ENDDO ENDDO !$acc end parallel ENDDO ELSE CALL z_int (outblock, i1,i2,i3, outblock%yvarzl(n), izdebug, zvarlev(:,:,1:outblock%kezin,0)) ENDIF kbot = 1 ktop = outblock%kezin slev(1:outblock%kezin) = outblock%zlev(1:outblock%kezin) ELSEIF ( ylist(n)(1:izlen) == 'ECHOTOP' .OR. ylist(n)(1:izlen) == 'ECHOTOPinM' ) THEN kbot = 1 ktop = MIN(nechotop, noutlevels) slev(1:ktop) = dbzthresh_echotop(1:ktop) zvarlev(:,:,kbot:ktop,0) = var(i1,i2,i3)%p3(:,:,kbot:ktop) ELSE !Calculate additional non-global 3-d fields if requird IF ( ylist(n)(1:izlen) == 'P' ) THEN kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = p0(i,j,k) + pp(i,j,k,itl) END DO END DO END DO !$acc end parallel #ifdef RADARFWO ELSEIF (ylist(n)(1:izlen) == 'DBZCMP_OBS' .OR. ylist(n)(1:izlen) == 'DBZCMP_SIM') THEN IF ( TRIM(outblock%yform_write) == 'bina' ) THEN ! Added section necessary for binary restart files: kbot = LBOUND (var(i1,i2,i3)%p3,3) ktop = UBOUND (var(i1,i2,i3)%p3,3) slev(kbot:ktop) = REAL((/ (i, i=kbot, ktop) /), KIND=wp) ELSE kbot = 1 ktop = 0 IF (ldo_bubbles) THEN ktop = ktop + 1 slev(1) = REAL(0, KIND=wp) END IF IF (ldo_composite) THEN slev(ktop+1:ktop+nel_composite) = REAL((/ (i, i=1, nel_composite) /), KIND=wp) ktop = ktop + nel_composite END IF ENDIF IF (ktop-kbot+1 > 0) THEN zvarp3_ptr => var(i1,i2,i3)%p3 DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp3_ptr(i,j,k) END DO END DO END DO END IF #endif ELSEIF (ylist(n)(1:izlen) == 'TKETENS' .AND. (.NOT. lzrestart) ) THEN kbot = 1 ktop = ke+1 SELECT CASE( itype_turb ) CASE( 5:8 ) zvarp3_ptr => var(i1,i2,i3)%p3 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp3_ptr(i,j,k) END DO END DO END DO !$acc end parallel CASE DEFAULT ! to get the correct unit for TKETENS zvarp3_ptr => var(i1,i2,i3)%p3 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp3_ptr(i,j,k) * tke(i,j,k,0,itl) END DO END DO END DO !$acc end parallel END SELECT ELSEIF (ylist(n)(1:izlen) == 'OMEGA') THEN kbot = 1 ktop = ke CALL calomega (zvarlev(:,:,kbot:ktop,0), pp(:,:,:,nnew), & pp(:,:,:,itl ), pptens(:,:,:), w(:,:,:,itl), & rho0(:,:,:), ie, je, ke, dt, g, lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'CLC') THEN kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = clc_sgs(i,j,k) & + clc_con(i,j,k)*(1.0_wp - clc_sgs(i,j,k)) END DO END DO END DO !$acc end parallel ELSEIF ( .NOT. lzrestart .AND. ylist(n)(1:izlen) == 'QRS' ) THEN kbot = 1 ktop = ke IF (outblock%loutput_q_densities) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zqrs_itl(i,j,k) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSE !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel END IF ELSEIF (ylist(n)(1:izlen) == 'Q_SEDIM') THEN kbot = 1 ktop = ke IF (ASSOCIATED(qi)) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zqrs_itl(i,j,k) - qi(i,j,k) END DO END DO END DO !$acc end parallel ELSE !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel ENDIF IF (outblock%loutput_q_densities) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarlev(i,j,k,0) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ENDIF ELSEIF (ylist(n)(1:izlen) == 'RELHUM') THEN kbot = 1 ktop = ke CALL calrelhum(zvarlev(:,:,kbot:ktop,0), t(:,:,:,itl), pp(:,:,:,itl),& p0(:,:,:), qv(:,:,:), ie, je, ke, & b1, b2w, b3, b4w, rdv, o_m_rdv, lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'BRN') THEN kbot = 1 ktop = ke !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL calc_bulk_richardson(zvarlev(:,:,kbot:ktop,0),t(:,:,:,itl), & qv(:,:,:), u(:,:,:,itl), v(:,:,:,itl), & zpres(:,:,:), hsurf(:,:), ps(:,:,itl), & t_2m(:,:,0), qv_2m(:,:,0),hhl(:,:,:), & ie, je, ke, cp_d, r_d, rvd_m_o, g, lacc=.TRUE.) !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zbrn(i,j,k) = zvarlev(i,j,k,0) END DO END DO END DO !$acc end parallel l_brn = .TRUE. ELSEIF (ylist(n)(1:izlen) == 'FI_ANAI') THEN kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = p_anai(i,j,k) / zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel #ifdef RADARFWO ELSEIF (ylist(n)(1:izlen) == 'DBZ') THEN kbot = 1 ktop = ke ! vectorized version of the radar routines: CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), zh_radar_wp = zvarlev(:,:,kbot:ktop,0)) CALL linear2dbz (zvarlev(:,:,kbot:ktop,0)) !UB ELSEIF (ylist(n)(1:izlen) == 'VTERM') THEN ELSEIF (ylist(n)(1:izlen) == 'DUMMY_1') THEN kbot = 1 ktop = ke ! vectorized version of the radar routines: IF (luse_radarfwo) THEN CALL calc_fallspeed_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, lwdbz=lweightdbz, & ldebug=ldebug_io, vt_radar_wp=zvarlev(:,:,kbot:ktop,0)) ELSE CALL calc_fallspeed_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, lwdbz=.TRUE., & ldebug=ldebug_io, vt_radar_wp=zvarlev(:,:,kbot:ktop,0)) END IF !UB ELSEIF (ylist(n)(1:izlen) == 'EXT_DBZ') THEN ELSEIF (ylist(n)(1:izlen) == 'DUMMY_2') THEN kbot = 1 ktop = ke ! vectorized version of the radar routines: CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), ah_radar_wp=zvarlev(:,:,kbot:ktop,0)) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = 20.0e3_wp / LOG(10.0_wp) * zvarlev(i,j,k,0) END DO END DO END DO #else ELSEIF (ylist(n)(1:izlen) == 'DBZ') THEN kbot = 1 ktop = ke IF (itype_gscp == 3) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, izdebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & z_radar = zvarlev(:,:,kbot:ktop,0), lacc=.TRUE. ) ELSEIF (itype_gscp == 4) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, izdebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & q_grau = zqg_itl(:,:,:), z_radar = zvarlev(:,:,kbot:ktop,0), & lacc=.TRUE. ) #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 100) THEN DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) zqh_itl(i,j,k) = qh(i,j,k)*zrho_itl(i,j,k) zqnc_itl(i,j,k) = qnc(i,j,k)*zrho_itl(i,j,k) zqnr_itl(i,j,k) = qnr(i,j,k)*zrho_itl(i,j,k) zqni_itl(i,j,k) = qni(i,j,k)*zrho_itl(i,j,k) zqns_itl(i,j,k) = qns(i,j,k)*zrho_itl(i,j,k) zqng_itl(i,j,k) = qng(i,j,k)*zrho_itl(i,j,k) zqnh_itl(i,j,k) = qnh(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO CALL radar_sb_ray (ie, je, ke, pi, & klv850, my_cart_id, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), & zqi_itl(:,:,:), zqs_itl(:,:,:), & zqg_itl(:,:,:), zqh_itl(:,:,:), & zqnc_itl(:,:,:), zqnr_itl(:,:,:), & zqni_itl(:,:,:), zqns_itl(:,:,:), & zqng_itl(:,:,:), zqnh_itl(:,:,:), & z_radar = zvarlev(:,:,kbot:ktop,0), lacc=.TRUE. ) #endif ENDIF CALL linear2dbz (zvarlev(:,:,kbot:ktop,0), lacc=.TRUE.) #endif ELSEIF ( ylist(n)(1:izlen) == 'VORTIC_U' ) THEN kbot = 1 ktop = ke CALL curl (ie, je, ke, eddlon, eddlat, r_earth, acrlat, tgrlat, & sqrtg_r_s, dzeta_dlam, dzeta_dphi, lmetr, wgtfac, & u(:,:,:,itl ), v(:,:,:,itl ), w(:,:,:,itl ), & .TRUE., zvarlev(:,:,1:ke,0), zhelp2(:,:,:), zhelp3(:,:,:),& lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'VORTIC_V' ) THEN kbot = 1 ktop = ke CALL curl (ie, je, ke, eddlon, eddlat, r_earth, acrlat, tgrlat, & sqrtg_r_s, dzeta_dlam, dzeta_dphi, lmetr, wgtfac, & u(:,:,:,itl ), v(:,:,:,itl ), w(:,:,:,itl ), & .TRUE., zhelp1(:,:,:), zvarlev(:,:,1:ke,0), zhelp3(:,:,:),& lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'VORTIC_W' ) THEN kbot = 1 ktop = ke CALL curl (ie, je, ke, eddlon, eddlat, r_earth, acrlat, tgrlat, & sqrtg_r_s, dzeta_dlam, dzeta_dphi, lmetr, wgtfac, & u(:,:,:,itl ), v(:,:,:,itl ), w(:,:,:,itl ), & .TRUE., zhelp1(:,:,:), zhelp2(:,:,:), zvarlev(:,:,1:ke,0),& lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'POT_VORTIC' ) THEN kbot = 1 ktop = ke CALL calc_Theta_Tppp( t(:,:,:,itl ), pp(:,:,:,itl ), p0, & ie, je, ke, r_d, cp_d, zhelp4, lacc=.TRUE.) CALL curl (ie, je, ke, eddlon, eddlat, r_earth, acrlat, tgrlat, & sqrtg_r_s, dzeta_dlam, dzeta_dphi, lmetr, wgtfac, & u(:,:,:,itl ), v(:,:,:,itl ), w(:,:,:,itl ), & .FALSE., zhelp1, zhelp2, zhelp3, lacc=.TRUE. ) ! coriolis parameter with cosine only available for deep atmosphere IF ( .NOT. lcori_deep ) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zhelp2d(i,j) = 0.0_wp END DO END DO !$acc end parallel ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zhelp2d(i,j) = fccos(i,j) END DO END DO !$acc end parallel ENDIF CALL potential_vorticity_rho( ie, je, ke, eddlon, eddlat, r_earth, & fc, zhelp2d, sqrtg_r_s, dzeta_dlam, dzeta_dphi, & zhelp1, zhelp2, zhelp3, lmetr, zhelp4, & u(:,:,:,itl), v(:,:,:,itl), w(:,:,:,itl), & zvarlev(:,:,1:ke,0), lacc=.TRUE. ) !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = 1,ke DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarlev(i,j,k,0) / zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ! CLM output ELSEIF ( ylist(n)(1:izlen) == 'DEN') THEN kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel #ifdef EULAG ELSEIF ( ylist(n)(1:izlen)=='WBC_EU') THEN kbot = 1 ktop = 2 zvarlev(istart:iend,jstart:jend,1:2,0) = var(i1,i2,i3)%p3(1:np,1:mp,1:2) ELSEIF (ylist(n)(1:izlen)=='U_ADV_EULAG' .OR. ylist(n)(1:izlen)=='U_EULAG_FC' .OR. & ylist(n)(1:izlen)=='V_ADV_EULAG' .OR. ylist(n)(1:izlen)=='V_EULAG_FC' .OR. & ylist(n)(1:izlen)=='W_ADV_EULAG' .OR. ylist(n)(1:izlen)=='W_EULAG_FC' .OR. & ylist(n)(1:izlen)=='TH_EULAG' .OR. ylist(n)(1:izlen)=='TH_EULAG_FC' .OR. & ylist(n)(1:izlen)=='TH_EULAG_B' .OR. ylist(n)(1:izlen)=='P_EULAG_B' .OR. & ylist(n)(1:izlen)=='PP_EULAG' .OR. ylist(n)(1:izlen)=='P_EULAG_OLD' .OR. & ylist(n)(1:izlen)=='PEXT_EULAG' .OR. ylist(n)(1:izlen)=='FP_EULAG' .OR. & ylist(n)(1:izlen)=='QV_RHS_F' .OR. & ylist(n)(1:izlen)=='SLV_EU_C11' .OR. ylist(n)(1:izlen)=='SLV_EU_C12' .OR. & ylist(n)(1:izlen)=='SLV_EU_C13' .OR. ylist(n)(1:izlen)=='SLV_EU_C21' .OR. & ylist(n)(1:izlen)=='SLV_EU_C22' .OR. ylist(n)(1:izlen)=='SLV_EU_C23' .OR. & ylist(n)(1:izlen)=='SLV_EU_C31' .OR. ylist(n)(1:izlen)=='SLV_EU_C32' .OR. & ylist(n)(1:izlen)=='SLV_EU_C33') THEN kbot = 1 ktop = ke zvarlev(istart:iend,jstart:jend,1:ke,0) = var(i1,i2,i3)%p3(1:np,1:mp,lp:1:-1) ELSEIF ( ylist(n)(1:izlen)=='U_EU_BC_LR'.OR.ylist(n)(1:izlen)=='V_EU_BC_LR'.OR. & ylist(n)(1:izlen)=='W_EU_BC_LR'.OR.ylist(n)(1:izlen)=='UBC_EU' ) THEN kbot = 1 CALL get_height_BAE (T_BAE_LR, ktop, izerror) CALL store_BAE (T_BAE_LR, var(i1,i2,i3)%p3, zvarlev(:,:,1:ke,0), izerror) IF (izerror /= 0) THEN CALL model_abort (my_cart_id, 2040, 'Error in store_BAE', 'store_BAE') ENDIF ELSEIF ( ylist(n)(1:izlen)=='U_EU_BC_BT'.OR.ylist(n)(1:izlen)=='V_EU_BC_BT'.OR. & ylist(n)(1:izlen)=='W_EU_BC_BT'.OR.ylist(n)(1:izlen)=='VBC_EU' ) THEN kbot = 1 CALL get_height_BAE (T_BAE_BT, ktop, izerror) CALL store_BAE (T_BAE_BT, var(i1,i2,i3)%p3, zvarlev(:,:,1:ke,0), izerror) IF (izerror /= 0) THEN CALL model_abort (my_cart_id, 2041, 'Error in store_BAE', 'store_BAE') ENDIF #endif #ifdef COSMOART ELSEIF ( l_cosmo_art.and.lvolcano .AND. ylist(n)(1:izlen) == 'ASH_MASSC' ) THEN kbot = LBOUND (cash,3) ktop = UBOUND (cash,3) DO k = 1,ke DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = 0.0_wp END DO END DO END DO IF ( .NOT. l_ash_massc ) THEN DO k = 1, ke DO j = 1, je DO i = 1, ie zash_massc(i,j,k) = 0.0_wp END DO END DO END DO DO isp = 1, isp_ash DO k = 1, ke DO j = 1, je DO i = 1, ie zash_massc(i,j,k) = zash_massc(i,j,k) & + ash_scale(isp) * cash(i,j,k,isp) ENDDO ENDDO ENDDO ENDDO l_ash_massc = .TRUE. ENDIF DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zash_massc(i,j,k) END DO END DO END DO #endif ELSEIF ( ylist(n)(1:izlen) == 'PT' ) THEN ! potential temperature kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = t(i,j,k,itl) * & (p0ref/(p0(i,j,k)+pp(i,j,k,itl)))**(r_d/cp_d) END DO END DO END DO !$acc end parallel ELSEIF ( ylist(n)(1:izlen) == 'THETA_V' ) THEN ! virtual potential temperature kbot = 1 ktop = ke !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = t(i,j,k,itl) * & (p0ref/(p0(i,j,k)+pp(i,j,k,itl)))**(r_d/cp_d) * & (1.0_wp + rvd_m_o * qv(i,j,k)) END DO END DO END DO !$acc end parallel ELSE IF (var(i1,i2,i3)%ltiles) THEN ! these are 2d variables with tiles but without a time dimension kbot = 1 ktop = 1 zvarp3_ptr => var(i1,i2,i3)%p3 !$acc parallel default(present) !$acc loop gang vector collapse(3) DO ntls = 0, nend_tile DO j = 1, je DO i = 1, ie zvarlev(i,j,1,ntls) = zvarp3_ptr(i,j,ntls) END DO END DO END DO !$acc end parallel ELSE ! these are the kind of variables as before kbot = LBOUND(var(i1,i2,i3)%p3,3) ktop = UBOUND(var(i1,i2,i3)%p3,3) ! decision, if mlf or slf zvarp3_ptr => var(i1,i2,i3)%p3 IF ( (ktop <= 3) .AND. (var(i1,i2,i3)%levtyp /= 233) ) THEN ! These are just 2D arrays with a timelevel and no special third dimension kbot = 1 ktop = 1 !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = zvarp3_ptr(i,j,itl) END DO END DO !$acc end parallel ELSE !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = kbot, ktop DO j = 1, je DO i = 1, ie zvarlev(i,j,k,0) = zvarp3_ptr(i,j,k) END DO END DO END DO !$acc end parallel ENDIF ENDIF ENDIF ENDIF ! Distribute the multidimensional fields to the PEs IF (yextension == 's') THEN #if defined RTTOV7 || defined RTTOV10 || defined RTTOV12 DO k=kbot,ktop IF ((nentry > 0) .AND. (sat_compute(nentry)%ngrib_chan(k) >= 0)) THEN nzrecords = nzrecords + 1 CALL output_data (nuedat, nzrecords, i1,i2,i3, k, ktop, izaee, & zvarlev(:,:,k,0), outblock, .FALSE., yextension, slev(k), & lzrestart, ivar_id(n), n, iorg_data, izdebug, lacc=.TRUE.) ENDIF ENDDO #endif ELSE DO ntls = 0, nend_tile izaee = ntls DO k=kbot,ktop nzrecords = nzrecords + 1 CALL output_data (nuedat, nzrecords, i1,i2,i3, k, ktop, izaee, & zvarlev(:,:,k,ntls), outblock, .FALSE., yextension, slev(k), & lzrestart, ivar_id(n), n, iorg_data, izdebug, lacc=.TRUE.) ENDDO ENDDO ENDIF CASE(2) ! Calculate additional non-global output fields if required IF ( ylist(n)(1:izlen) == 'PMSL' ) THEN CALL calpmsl( zvarlev(:,:,1,0), ps(:,:,itl), t(:,:,ke,itl), & rho0(:,:,ke), dp0(:,:,ke), hsurf, ie, je, g, r_d, & lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'TOT_PREC' ) THEN IF (itype_gscp >= 4 .AND. itype_gscp < 2000) THEN !$acc data present(grau_gsp, rain_con, snow_con, snow_gsp, rain_gsp) !$acc kernels default(present) zgsp(:,:) = snow_gsp(:,:) + grau_gsp(:,:) !$acc end kernels CALL calprsum( zvarlev(:,:,1,0), rain_gsp, zgsp, & rain_con, snow_con, ie, je, lacc=.TRUE. ) !$acc end data #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 2000) THEN CALL calprsum( zvarlev(:,:,1,0), rain_gsp, snow_gsp + grau_gsp + hail_gsp, & rain_con, snow_con, ie, je, lacc=.FALSE. ) #endif ELSE !$acc data present(rain_gsp, snow_gsp, rain_con, snow_con) CALL calprsum( zvarlev(:,:,1,0), rain_gsp, snow_gsp, rain_con, & snow_con, ie, je, lacc=.TRUE. ) !$acc end data ENDIF ELSEIF ( ylist(n)(1:izlen) == 'TOT_PR' ) THEN IF (itype_gscp >= 4 .AND. itype_gscp < 2000) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = prr_gsp(i,j) + prs_gsp(i,j) + prg_gsp(i,j) + & prr_con(i,j) + prs_con(i,j) END DO END DO !$acc end parallel #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 2000) THEN DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = prr_gsp(i,j) + prs_gsp(i,j) + prg_gsp(i,j) + & prh_gsp(i,j) + prr_con(i,j) + prs_con(i,j) END DO END DO #endif ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = prr_gsp(i,j) + prs_gsp(i,j) + & prr_con(i,j) + prs_con(i,j) END DO END DO !$acc end parallel ENDIF ELSEIF ( ylist(n)(1:izlen) == 'HTOP_DC' ) THEN CALL caltopdc( zvarlev(:,:,1,0), t(:,:,:,itl), p0, pp(:,:,:,itl), & qv(:,:,:), hhl, hhl_prof, ie, je, ke, & b1, b2w, b3, b4w, rdv, o_m_rdv, rvd_m_o, cpdr, & g, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'FIS' ) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = hsurf(i,j) * g END DO END DO !$acc end parallel ELSEIF ( ylist(n)(1:izlen) == 'HTOP_CON' .OR. & ylist(n)(1:izlen) == 'HTOP_SC' ) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j= 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp klev = NINT( top_con(i,j) ) IF(klev > 0) THEN zvarlev(i,j,1,0) = 0.5_wp*(hhl(i,j,klev)+hhl(i,j,klev+1)) ENDIF ENDDO ENDDO !$acc end parallel ELSEIF ( ylist(n)(1:izlen) == 'HBAS_CON' .OR. & ylist(n)(1:izlen) == 'HBAS_SC' ) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j= 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp klev = NINT( bas_con(i,j) ) IF(klev > 0 .and. klev <=ke+1) THEN zvarlev(i,j,1,0) = hhl(i,j,klev) ENDIF ENDDO ENDDO !$acc end parallel ELSEIF ( ylist(n)(1:izlen) == 'RAPA_SPPT' ) THEN IF (lsppt) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie ! pertstoph profiles has a positive or negative deviation ! from 1.0. Due to the tapering the values are not identical ! at all levels but the sign is the same. ! RAPA_SPPT is the maximal deviation in k for every i,j zvarlev(i,j,1,0) = MAXVAL(pertstoph(i,j,:)) IF ( zvarlev(i,j,1,0) == 1.0_wp ) THEN zvarlev(i,j,1,0) = MINVAL(pertstoph(i,j,:)) ENDIF END DO END DO !$acc end parallel ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 1.0_wp END DO END DO !$acc end parallel ENDIF ELSEIF ( ylist(n)(1:izlen) == 'HZEROCL' ) THEN CALL calhzero( zvarlev(:,:,1,0), t(:,:,:,itl), hhl, hhl_prof, & ie, je, ke, t0_melt, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'SNOWLMT' ) THEN CALL calsnowlmt( zvarlev(:,:,1,0), t(:,:,:,itl), pp(:,:,:,itl), & p0(:,:,:), qv(:,:,:), hhl, hhl_prof, ie, je, ke, & t0_melt, 1.3_wp, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'CLCT_MOD' ) THEN CALL calclmod(zvarlev(:,:,1,0), clc_sgs, clc_con, p0hl, pi, ie, & je, ke, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'CLDEPTH' ) THEN CALL calcldepth( zvarlev(:,:,1,0), clc_sgs, clc_con, dp0, ie, & je, ke, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'TQV' ) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qv(:,:,: ), ie, je, & ke, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'TQC' ) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qc(:,:,: ), ie, je, & ke, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'TQR' ) THEN IF ( ASSOCIATED(qr) ) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qr(:,:,: ), ie, je, & ke, lacc=.TRUE. ) ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp END DO END DO !$acc end parallel ENDIF ELSEIF ( ylist(n)(1:izlen) == 'TQS' ) THEN IF ( ASSOCIATED(qs) ) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qs(:,:,: ), ie, je, & ke, lacc=.TRUE. ) ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp END DO END DO !$acc end parallel ENDIF ELSEIF ( ylist(n)(1:izlen) == 'TQG' ) THEN IF ( ASSOCIATED(qg) ) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qg(:,:,: ), ie, je, ke, & lacc=.TRUE. ) ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp END DO END DO !$acc end parallel ENDIF #ifdef TWOMOM_SB ELSEIF ( ylist(n)(1:izlen) == 'TQH' ) THEN IF ( itype_gscp >= 2000 ) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qh(:,:,: ), ie, je, ke, & lacc=.TRUE. ) ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp END DO END DO !$acc end parallel ENDIF #endif ELSEIF ( (ylist(n)(1:izlen) == 'ZTD') .OR. & (ylist(n)(1:izlen) == 'ZWD') .OR. & (ylist(n)(1:izlen) == 'ZHD') ) THEN IF (.NOT. lzenith) THEN !$acc data present(zenith_t, zenith_w, zenith_h) CALL calztd( zenith_t(:,:), zenith_w(:,:), zenith_h(:,:), & zrho_itl, hhl, qv(:,:,: ), ps(:,:,itl ), & t(:,:,ke,itl ), hsurf, rlat, pi, ie, je, ke, lacc=.TRUE. ) !$acc end data lzenith = .TRUE. ENDIF ELSEIF ( (ylist(n)(1:izlen) == 'TWATER' ) .OR. & (ylist(n)(1:izlen) == 'TWATFLXU') .OR. & (ylist(n)(1:izlen) == 'TWATFLXV') ) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = 1, ke DO j = 1, je DO i = 1, ie zvarlev(i,j,k+1,0) = qv (i,j,k) + qc(i,j,k) + zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel IF (ylist(n)(1:izlen) == 'TWATER') THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, zvarlev(:,:,2:ke+1,0), ie,je,ke, lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'TWATFLXU') THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, zvarlev(:,:,2:ke+1,0), ie,je,ke, wind=u_m, lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'TWATFLXV') THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, zvarlev(:,:,2:ke+1,0), ie,je,ke, wind=v_m, lacc=.TRUE. ) ENDIF ELSEIF ( ylist(n)(1:izlen) == 'TQI') THEN IF (ASSOCIATED(qi)) THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qi(:,:,:), ie,je,ke, lacc=.TRUE. ) ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp END DO END DO !$acc end parallel ENDIF ELSEIF ( ylist(n)(1:izlen) == 'TQV_ANAI') THEN ! for analysis increments, using rho(nnow) is sufficiently accurate CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qv_anai(:,:,:), ie,je,ke, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'TQC_ANAI') THEN CALL caliq( zvarlev(:,:,1,0), zrho_itl, hhl, qc_anai(:,:,:), ie,je,ke, lacc=.TRUE. ) ELSEIF ( ylist(n)(1:izlen) == 'PMSL_ANAI') THEN CALL calpmsl( zvarlev(:,:,1,0), ps(:,:,itl), t(:,:,ke,itl), & rho0(:,:,ke), dp0(:,:,ke), hsurf, ie, je, g, r_d, lacc=.TRUE. ) !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = p_anai(i,j,ke) * zvarlev(i,j,1,0) & /(p0(i,j,ke) + pp(i,j,ke,itl)) END DO END DO !$acc end parallel ELSEIF ( (ylist(n)(1:izlen) == 'AUMFL_S') .AND. & (.NOT. lzrestart) .AND. outblock%luvmasspoint) THEN ! Exchange aumfl_s first kzdims(1:24)=(/1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute,& ie, je, kzdims, jstartpar, jendpar, & nbl_exchg, nboundlines, my_cart_neigh, lperi_x, lperi_y, l2dim, & 20000+nexch_tag, .FALSE. , ncomm_type, izerror, yerrmsg, & var(i1,i2,i3)%p2(:,:)) DO j = 1, je DO i = 2, ie zvarlev(i,j,1,0) = 0.5_wp * (var(i1,i2,i3)%p2(i-1,j) + & var(i1,i2,i3)%p2(i ,j)) ENDDO zvarlev(1,j,1,0) = zvarlev(2,j,1,0) ENDDO ELSEIF ( (ylist(n)(1:izlen) == 'AVMFL_S') .AND. & (.NOT. lzrestart) .AND. outblock%luvmasspoint) THEN ! Exchange avmfl_s first kzdims(1:24)=(/1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute,& ie, je, kzdims, jstartpar, jendpar, & nbl_exchg, nboundlines, my_cart_neigh, lperi_x, lperi_y, l2dim, & 20000+nexch_tag, .FALSE. , ncomm_type, izerror, yerrmsg, & var(i1,i2,i3)%p2(:,:)) DO j = 2, je DO i = 1, ie zvarlev(i,j,1,0) = 0.5_wp * (var(i1,i2,i3)%p2(i,j-1) + & var(i1,i2,i3)%p2(i,j )) ENDDO ENDDO zvarlev(:,1,1,0) = zvarlev(:,2,1,0) #ifdef RADARFWO ELSEIF (ylist(n)(1:izlen) == 'DBZ_850') THEN CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), zh_radar_850_wp = zvarlev(:,:,1,0)) CALL linear2dbz (zvarlev(:,:,1,0)) ELSEIF (ylist(n)(1:izlen) == 'DBZ_CMAX') THEN CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), zh_radar_cmax_wp = zvarlev(:,:,1,0)) CALL linear2dbz (zvarlev(:,:,1,0)) #else ELSEIF (ylist(n)(1:izlen) == 'DBZ_850') THEN IF (itype_gscp == 3) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, izdebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & z_radar_850 = zvarlev(:,:,1,0), lacc=.TRUE. ) ELSEIF (itype_gscp == 4) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, izdebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & q_grau = zqg_itl(:,:,:), z_radar_850 = zvarlev(:,:,1,0), & lacc=.TRUE. ) #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 100) THEN DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) zqh_itl(i,j,k) = qh(i,j,k)*zrho_itl(i,j,k) zqnc_itl(i,j,k) = qnc(i,j,k)*zrho_itl(i,j,k) zqnr_itl(i,j,k) = qnr(i,j,k)*zrho_itl(i,j,k) zqni_itl(i,j,k) = qni(i,j,k)*zrho_itl(i,j,k) zqns_itl(i,j,k) = qns(i,j,k)*zrho_itl(i,j,k) zqng_itl(i,j,k) = qng(i,j,k)*zrho_itl(i,j,k) zqnh_itl(i,j,k) = qnh(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO CALL radar_sb_ray (ie, je, ke, pi, & klv850, my_cart_id, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), & zqi_itl(:,:,:), zqs_itl(:,:,:), & zqg_itl(:,:,:), zqh_itl(:,:,:), & zqnc_itl(:,:,:), zqnr_itl(:,:,:), & zqni_itl(:,:,:), zqns_itl(:,:,:), & zqng_itl(:,:,:), zqnh_itl(:,:,:), & z_radar_850 = zvarlev(:,:,1,0), lacc=.TRUE. ) #endif ENDIF CALL linear2dbz (zvarlev(:,:,1,0), lacc=.TRUE.) ELSEIF (ylist(n)(1:izlen) == 'DBZ_CMAX') THEN IF (itype_gscp == 3) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, izdebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & z_radar_cmax = zvarlev(:,:,1,0), lacc=.TRUE. ) ELSEIF (itype_gscp == 4) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, izdebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & q_grau = zqg_itl(:,:,:), z_radar_cmax = zvarlev(:,:,1,0), & lacc=.TRUE. ) #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 100) THEN DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) zqh_itl(i,j,k) = qh(i,j,k)*zrho_itl(i,j,k) zqnc_itl(i,j,k) = qnc(i,j,k)*zrho_itl(i,j,k) zqnr_itl(i,j,k) = qnr(i,j,k)*zrho_itl(i,j,k) zqni_itl(i,j,k) = qni(i,j,k)*zrho_itl(i,j,k) zqns_itl(i,j,k) = qns(i,j,k)*zrho_itl(i,j,k) zqng_itl(i,j,k) = qng(i,j,k)*zrho_itl(i,j,k) zqnh_itl(i,j,k) = qnh(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO CALL radar_sb_ray (ie, je, ke, pi, & klv850, my_cart_id, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), & zqi_itl(:,:,:), zqs_itl(:,:,:), & zqg_itl(:,:,:), zqh_itl(:,:,:), & zqnc_itl(:,:,:), zqnr_itl(:,:,:), & zqni_itl(:,:,:), zqns_itl(:,:,:), & zqng_itl(:,:,:), zqnh_itl(:,:,:), & z_radar_cmax = zvarlev(:,:,1,0), lacc=.TRUE. ) #endif ENDIF CALL linear2dbz (zvarlev(:,:,1,0), lacc=.TRUE.) #endif ELSEIF (ylist(n)(1:izlen) == 'SWISS00') THEN !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL cal_conv_ind (t(:,:,:,itl), qv(:,:,:), & u(:,:,:,itl), v(:,:,:,itl),hsurf(:,:),ps(:,:,itl), & zpres(:,:,:), hhl(:,:,:), ie, je, ke, b1, b2w, b3, & b4w, lh_v, cp_d, r_d, rdv, rvd_m_o, o_m_rdv, g, & missing_value, izdebug, lwarn, ierrstat, yerrmsg, & swiss00 = zvarlev(:,:,1,0), lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'SWISS12') THEN !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL cal_conv_ind (t(:,:,:,itl), qv(:,:,:), & u(:,:,:,itl), v(:,:,:,itl),hsurf(:,:),ps(:,:,itl), & zpres(:,:,:), hhl(:,:,:), ie, je, ke, b1, b2w, b3, & b4w, lh_v, cp_d, r_d, rdv, rvd_m_o, o_m_rdv, g, & missing_value, izdebug, lwarn, ierrstat, yerrmsg, & swiss12 = zvarlev(:,:,1,0), lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'SI') THEN !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL cal_conv_ind (t(:,:,:,itl), qv(:,:,:), & u(:,:,:,itl), v(:,:,:,itl),hsurf(:,:),ps(:,:,itl), & zpres(:,:,:), hhl(:,:,:), ie, je, ke, b1, b2w, b3, & b4w, lh_v, cp_d, r_d, rdv, rvd_m_o, o_m_rdv, g, & missing_value, izdebug, lwarn, ierrstat, yerrmsg, & si= zvarlev(:,:,1,0), lacc=.TRUE. ) ELSEIF (ylist(n)(1:izlen) == 'SLI') THEN !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL cal_conv_ind (t(:,:,:,itl), qv(:,:,:), & u(:,:,:,itl), v(:,:,:,itl),hsurf(:,:),ps(:,:,itl), & zpres(:,:,:), hhl(:,:,:), ie, je, ke, b1, b2w, b3, & b4w, lh_v, cp_d, r_d, rdv, rvd_m_o, o_m_rdv, g, & missing_value, izdebug, lwarn, ierrstat, yerrmsg, & sli= zvarlev(:,:,1,0), lacc=.TRUE. ) ELSEIF ( (ylist(n)(1:izlen) == 'CAPE_MU') .OR. & (ylist(n)(1:izlen) == 'CIN_MU') ) THEN IF (.NOT. lconvind_mu) THEN !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL cal_conv_ind (t(:,:,:,itl), qv(:,:,:), & u(:,:,:,itl), v(:,:,:,itl),hsurf(:,:),ps(:,:,itl), & zpres(:,:,:), hhl(:,:,:), ie, je, ke, b1, b2w, & b3, b4w, lh_v, cp_d, r_d, rdv, rvd_m_o, o_m_rdv, g, & missing_value, izdebug, lwarn, ierrstat, yerrmsg, & cape_mu=zcape_mu, cin_mu=zcin_mu, lacc=.TRUE. ) lconvind_mu = .TRUE. ENDIF ELSEIF ( (ylist(n)(1:izlen) == 'CAPE_ML') .OR. & (ylist(n)(1:izlen) == 'CIN_ML') .OR. & (ylist(n)(1:izlen) == 'LCL_ML') .OR. & (ylist(n)(1:izlen) == 'LFC_ML') .OR. & (ylist(n)(1:izlen) == 'CAPE_3KM') ) THEN IF (.NOT. lconvind_ml) THEN !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL cal_conv_ind (t(:,:,:,itl), qv(:,:,:), & u(:,:,:,itl), v(:,:,:,itl),hsurf(:,:),ps(:,:,itl), & zpres(:,:,:), hhl(:,:,:), ie, je, ke, b1, b2w, & b3, b4w, lh_v, cp_d, r_d, rdv, rvd_m_o, o_m_rdv, g, & missing_value, izdebug, lwarn, ierrstat, yerrmsg, & cape_ml=zcape_ml, cin_ml=zcin_ml, lcl_ml=zlcl_ml, & lfc_ml=zlfc_ml, cape_3km=zcape_3km, lacc=.TRUE. ) lconvind_ml = .TRUE. ENDIF ELSEIF (ylist(n)(1:izlen) == 'HPBL') THEN IF (.NOT. l_brn) THEN kbot = 1 ktop = ke #ifndef MESSY !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL calc_bulk_richardson(zvarlev(:,:,kbot:ktop,0),t(:,:,:,itl),& qv(:,:,:), u(:,:,:,itl), v(:,:,:,itl), & zpres(:,:,:), hsurf(:,:), ps(:,:,itl), & t_2m(:,:,0), qv_2m(:,:,0),hhl(:,:,:), & ie, je, ke, cp_d, r_d, rvd_m_o, g, lacc=.TRUE. ) l_brn = .TRUE. !$acc kernels default(present) zbrn(:,:,:) = zvarlev(:,:,kbot:ktop,0) !$acc end kernels #else !$acc kernels default(present) zpres(:,:,:) = p0(:,:,:)+pp(:,:,:,itl) !$acc end kernels CALL calc_bulk_richardson(zbrn(:,:,:),t(:,:,:,itl), & qv(:,:,:), u(:,:,:,itl), v(:,:,:,itl), & zpres(:,:,:), hsurf(:,:), ps(:,:,itl), & t_2m(:,:,0), qv_2m(:,:,0), hhl(:,:,:), & ie, je, ke, cp_d, r_d, rvd_m_o, g, lacc=.FALSE. ) l_brn = .TRUE. #endif ENDIF CALL calc_pbl_brn(t(:,:,:,itl), qv(:,:,:), & zpres(:,:,:), hhl(:,:,:),hsurf(:,:), & zbrn(:,:,:), ie, je, ke, cp_d, r_d, rvd_m_o, missing_value,& zvarlev(:,:,1,0), lacc=.TRUE. ) #ifndef MESSY !$acc kernels default(present) zvarlev(:,:,0,0)=zvarlev(:,:,1,0) !$acc end kernels #endif ELSEIF (ylist(n)(1:izlen) == 'CEILING') THEN CALL calc_ceiling( zvarlev(:,:,1,0), clc_sgs, hhl, ie, je, ke, lacc=.TRUE. ) #ifndef MESSY ELSEIF ( (ylist(n)(1:izlen) == 'SDI_1') .OR. & (ylist(n)(1:izlen) == 'SDI_2') ) THEN IF (.NOT. l_calc_sdi_already_comp ) THEN CALL calc_sdi( zvarlev(:,:,1,0), zvarlev(:,:,2,0),lacc=.TRUE. ) l_calc_sdi_already_comp = .TRUE. END IF #else ELSE IF (ylist(n)(1:izlen) == 'SDI_1') THEN CALL calc_sdi( zvarlev(:,:,1,0), dummy ) ELSE IF (ylist(n)(1:izlen) == 'SDI_2') THEN CALL calc_sdi( dummy, zvarlev(:,:,1,0) ) #endif ELSEIF ( (ylist(n)(1:izlen) == 'DHAIL_AV') ) THEN !$acc kernels default(present) DO j = 1, SIZE(dhail,2) DO i = 1, SIZE(dhail,1) zvarlev(i,j,1,0) = SUM(dhail(i,j,:)) / REAL(SIZE(dhail,3),wp) END DO END DO !$acc end kernels ELSEIF ( (ylist(n)(1:izlen) == 'DHAIL_SD') ) THEN !$acc kernels default(present) zvarlev(:,:,1,0) = 0.0_wp DO j = 1, SIZE(dhail,2) DO i = 1, SIZE(dhail,1) ! mean zvarlev(i,j,2,0) = SUM(dhail(i,j,:)) / REAL(SIZE(dhail,3),wp) DO k = 1, SIZE(dhail,3) ! Standard deviation zvarlev(i,j,1,0) = zvarlev(i,j,1,0) + ( dhail(i,j,k) - zvarlev(i,j,2,0) )**2 END DO zvarlev(i,j,1,0) = SQRT( zvarlev(i,j,1,0) ) / REAL(SIZE(dhail,3)-1,wp) END DO END DO !$acc end kernels ELSEIF ( (ylist(n)(1:izlen) == 'DHAIL_MX') ) THEN ! maximum !$acc kernels default(present) DO j = 1, SIZE(dhail,2) DO i = 1, SIZE(dhail,1) zvarlev(i,j,1,0) = MAX( dhail(i,j,1),dhail(i,j,2),dhail(i,j,3),dhail(i,j,4),dhail(i,j,5)) END DO END DO !$acc end kernels ELSEIF ( (ylist(n)(1:izlen) == 'W_UP_DUR') ) THEN ! updraft duration !$acc kernels default(present) zvarlev(:,:,1,0) = wup_dur(:,:) !$acc end kernels ELSEIF ( (ylist(n)(1:izlen) == 'W_UP_MASK') ) THEN ! updraft mask !$acc kernels default(present) zvarlev(:,:,1,0) = wup_mask(:,:) !$acc end kernels #ifdef COSMOART ELSEIF ( l_cosmo_art.and.lvolcano .AND. & ( ylist(n)(1:izlen) == 'ASH_HMLMAX' .OR. & ylist(n)(1:izlen) == 'ASH_100MAX' .OR. & ylist(n)(1:izlen) == 'ASH_245MAX' .OR. & ylist(n)(1:izlen) == 'ASH_390MAX' .OR. & ylist(n)(1:izlen) == 'ASH_530MAX' .OR. & ylist(n)(1:izlen) == 'ASH_200MAX' .OR. & ylist(n)(1:izlen) == 'ASH_350MAX' .OR. & ylist(n)(1:izlen) == 'ASH_550MAX' .OR. & ylist(n)(1:izlen) == 'ASH_TCLOAD' ) & ) THEN zvarlev = 0.0_wp IF ( .NOT. l_ash_massc ) THEN zash_massc = 0.0_wp DO isp = 1, isp_ash DO k = 1, ke DO j = 1, je DO i = 1, ie zash_massc(i,j,k) = zash_massc(i,j,k) & + ash_scale(isp) * cash(i,j,k,isp) ENDDO ENDDO ENDDO ENDDO l_ash_massc = .TRUE. ENDIF IF ( ylist(n)(1:izlen) == 'ASH_HMLMAX' ) THEN DO j = 1, je DO i = 1, ie WHERE ( zash_massc(i,j,:) >= 200.0_wp ) zash_massc_mask(:) = .TRUE. ELSEWHERE zash_massc_mask(:) = .FALSE. END WHERE IF ( ANY( zash_massc_mask(:) ) ) THEN zmaxloc(:) = MAXLOC( zash_massc(i,j,:), zash_massc_mask(:) ) zvarlev(i,j,1,0) = 0.5_wp * ( hhl(i,j,zmaxloc(1)+1) + hhl(i,j,zmaxloc(1)) ) ELSE zvarlev(i,j,1,0) = 0.0_wp ENDIF ENDDO ENDDO ELSEIF ( ylist(n)(1:izlen) == 'ASH_TCLOAD' ) THEN ztc_factor(:,:,:) = 1.0E-6_wp CALL caliq( zvarlev(:,:,1,0), ztc_factor(:,:,:), hhl, zash_massc(:,:,:), ie, je, ke, lacc=.FALSE. ) ELSE SELECT CASE( ylist(n)(1:izlen) ) CASE('ASH_100MAX') zpres_bot = -1.0_wp zpres_top = 70000.0_wp CASE('ASH_245MAX') zpres_bot = 70000.0_wp zpres_top = 38500.0_wp CASE('ASH_390MAX') zpres_bot = 38500.0_wp zpres_top = 20000.0_wp CASE('ASH_530MAX') zpres_bot = 20000.0_wp zpres_top = 10000.0_wp CASE('ASH_200MAX') zpres_bot = -1.0_wp zpres_top = 46500.0_wp CASE('ASH_350MAX') zpres_bot = 46500.0_wp zpres_top = 24000.0_wp CASE('ASH_550MAX') zpres_bot = 24000.0_wp zpres_top = 9100.0_wp END SELECT CALL max_in_pressure_layers( zash_massc(:,:,:), & pp(:,:,:,itl), p0(:,:,:), & ie, je, ke, & zvarlev(:,:,1,0), & zpres_bot, zpres_top ) ENDIF #endif ELSEIF (ylist(n)(1:izlen) == 'LPI' .OR. ylist(n)(1:izlen) == 'LPI_BUO') THEN IF (itype_gscp >= 4) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = 1, ke !$NEC IVDEP !DIR$ IVDEP DO j = 1, je DO i = 1, ie zhelp1(i,j,k) = qg(i,j,k) END DO END DO END DO !$acc end parallel #ifdef TWOMOM_SB IF (itype_gscp >= 2000) THEN zhelp1(:,:,:) = zhelp1(:,:,:) + qh(:,:,:) ENDIF #endif !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k = 1 ,ke !$NEC IVDEP !DIR$ IVDEP DO j = 1, je DO i = 1, ie pdot(i,j,k)= p0(i,j,k) + pp(i,j,k,itl) END DO END DO END DO !$acc end parallel CALL lightning_potential_index( zvarlev(:,:,1,0), zvarlev(:,:,2,0), 0.5_wp, & ie, je, ke, jstartpar, jendpar, hhl, w(:,:,:,itl), t(:,:,:,itl), & pdot(:,:,:), qv(:,:,:), qc(:,:,:), qr(:,:,:), qi(:,:,:), qs(:,:,:), & zhelp1(:,:,:), t0_melt, r_d, r_v, cp_d, cp_d/(rcpv+1.0_wp), & lh_v, 4200.0_wp, p0ref, b1, b2w, b3, b4w) IF (ylist(n)(1:izlen) == 'LPI') THEN ipe_out = MOD(nzrecords+1-1,num_compute) IF (.NOT.ALLOCATED(wmax_tot)) THEN ALLOCATE (wmax_loc(ie, je), buo_loc(ie, je)) IF (my_cart_id == ipe_out) THEN ALLOCATE (wmax_tot(ie_tot, je_tot), buo_tot(ie_tot, je_tot)) ELSE ALLOCATE (wmax_tot(0,0), buo_tot(0,0)) END IF ENDIF !$acc enter data create (wmax_loc, buo_loc) ! Use single precision fields for global communications to save some time: IF (num_compute > 1) THEN !$acc parallel default(present) !$acc loop gang vector collapse(2) !$NEC IVDEP !DIR$ IVDEP DO j = 1, je DO i = 1, ie wmax_loc(i,j) = REAL(MAXVAL(w(i,j,:,itl)), kind=sp) buo_loc(i,j) = REAL(zvarlev(i,j,2,0), kind=sp) END DO END DO !$acc end parallel !$acc update host(wmax_loc,buo_loc) CALL gather_field (wmax_loc, ie,je, wmax_tot, ie_tot,je_tot, ipe_out, izerror) CALL gather_field (buo_loc , ie,je, buo_tot, ie_tot,je_tot, ipe_out, izerror) ELSE !$acc parallel default(present) !$acc loop gang vector collapse(2) DO j = 1, je_tot DO i = 1, ie_tot wmax_tot(i,j) = REAL(MAXVAL(w(i,j,:,itl)), kind=sp) buo_tot(i,j) = REAL(zvarlev(i,j,2,0), kind=sp) END DO END DO !$acc end parallel END IF ENDIF ELSE WRITE(*,*) 'WARNING: ' // ylist(n)(1:izlen) // & ' only meaningful with prognostic graupel (itype_gscp >= 4). Is set to 0.0 in output file.' !$acc parallel default(present) !$acc loop gang vector collapse(2) !$NEC IVDEP !DIR$ IVDEP DO j = 1, je DO i = 1, ie zvarlev(i,j,1,0) = 0.0_wp zvarlev(i,j,2,0) = 0.0_wp END DO END DO !$acc end parallel ENDIF ELSEIF (ylist(n)(1:izlen) == 'MCONV') THEN ! Average moisture convergence from 0 to 1000 m AGL: zh_bot = 0.0_wp ! m AGL zh_top = 1000.0_wp ! m AGL CALL hor_moisture_convergence ( zh_bot, zh_top, ie, je, ke, istart, iend, jstart, jend, & dlon, dlat, r_earth, crlat(:,1), & hhl(:,:,:), u(:,:,:,itl), v(:,:,:,itl), qv(:,:,:), & zvarlev(:,:,1,0), lsmooth=.TRUE.) ELSE IF (ASSOCIATED(var(i1,i2,i3)%p2)) THEN zvarp2_ptr => var(i1,i2,i3)%p2 !$acc kernels default(present) zvarlev(1:ie,1:je,1,0) = zvarp2_ptr(1:ie,1:je) !$acc end kernels ELSE PRINT *, ' *** ERROR: Trying to output unassociated variable: ', & ylist(n)(1:izlen) ENDIF ENDIF nzrecords = nzrecords+1 IF ( ylist(n)(1:izlen) == 'ZTD' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zenith_t(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zenith_t(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'ZWD' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zenith_W(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zenith_w(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'ZHD' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zenith_h(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zenith_h(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'CAPE_MU' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zcape_mu(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zcape_mu(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'CIN_MU' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zcin_mu(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zcin_mu(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'CAPE_ML' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zcape_ml(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zcape_ml(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'CIN_ML' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zcin_ml(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zcin_ml(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'LCL_ML' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zlcl_ml(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zlcl_ml(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'LFC_ML' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zlfc_ml(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zlfc_ml(:,:), & outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'CAPE_3KM' ) THEN #ifdef MESSY channeli%this%vars(n)%ptr(:,:,1,1) = zcape_3km(:,:) #endif CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zcape_3km(:,:),& outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'SDI_1' ) THEN CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zvarlev(:,:,1,0),& outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'SDI_2' ) THEN #ifndef MESSY CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zvarlev(:,:,2,0),& #else CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zvarlev(:,:,1,0),& #endif outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSEIF ( ylist(n)(1:izlen) == 'LPI_BUO' ) THEN ! only for testing purposes, not an official grib field! CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zvarlev(:,:,2,0),& outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ELSE CALL output_data (nuedat,nzrecords, i1,i2,i3, 1, 1, izaee, zvarlev(:,:,1,0),& outblock, .FALSE., yextension, slev(1), & lzrestart, ivar_id(n), n, iorg_data, izdebug, & lacc=.TRUE.) ENDIF END SELECT ! set flag lout_done to TRUE for variables in the model level list IF (yextension == ' ') THEN var(i1,i2,i3)%lout_done = .TRUE. ENDIF ENDDO write_loop !------------------------------------------------------------------------------ ! Section 4: Flush output buffers and close grib file !------------------------------------------------------------------------------ #ifdef MESSY IF (l_COSMO_now .AND. L_BM_ORIG_OUTPUT) THEN #endif CALL output_data (nuedat, -1, -1,-1,-1, -1, -1, izaee, zvarlev(:,:,1,0), & outblock, .TRUE., yextension, 0.0_wp, lzrestart, -1, & -1, iorg_data, izdebug, lacc=.TRUE.) !US old: IF (outblock%yform_write /= 'ncdf' .OR. nc_asyn_io < 1) THEN !US test: IF ((outblock%yform_write /= 'ncdf' .AND. outblock%yform_write /= 'nc-4') & .OR. nc_asyn_io < 1 .OR. lzrestart) THEN ! from ncdf restart: IF (outblock%yform_write == 'ncdf' .AND. (nc_asyn_io < 1 .OR. lzrestart)) THEN !US but what about grib files????? CALL close_file (nuedat, TRIM(outblock%yform_write), icomm_cart, my_cart_id, & num_compute, lasync_io, yname, llockfiles, idbg_level, & yerrmsg, ierrstat) IF (ierrstat /= 0) THEN CALL model_abort (my_cart_id, 2034, yerrmsg, yroutine) ENDIF ENDIF #ifdef MESSY ENDIF #endif IF (outblock%yform_write == 'bina') THEN ! release the unit-number again CALL release_unit (nuedat) ENDIF ! Write a blank line to YUCHKDAT IF ( (outblock%lcheck) .AND. (my_cart_id == 0) ) THEN WRITE (nuchkdat,'(A)') ' ' WRITE (nuchkdat,'(A)') ' ' ENDIF ! close file nuchkdat IF ( (outblock%lcheck) .AND. (my_cart_id == 0) ) THEN CLOSE (nuchkdat, STATUS='KEEP') ENDIF ! Deallocate arrays for IO DEALLOCATE (iblock, ibmap, ds_real, ds_grib, dsup, ymessage) ! Deallocate arrays for densities !$acc exit data delete(zrho_itl, zqrs_itl, zqc_itl, zqr_itl, zqi_itl, & !$acc zqs_itl, zqg_itl) DEALLOCATE ( zrho_itl, zqrs_itl, zqc_itl, zqr_itl, zqi_itl, zqs_itl, zqg_itl ) #ifdef TWOMOM_SB IF (itype_gscp >= 100) THEN DEALLOCATE ( zqh_itl, zqnc_itl, zqnr_itl, zqni_itl, zqns_itl, zqng_itl, zqnh_itl ) ENDIF #endif IF (outblock%l_fi_pmsl_smooth) THEN DEALLOCATE (hsurf_tot) ENDIF IF (ALLOCATED(wmax_tot)) THEN !$acc exit data delete(buo_loc, wmax_loc) DEALLOCATE (wmax_tot, buo_tot, wmax_loc, buo_loc) END IF !$acc exit data delete( zvarlev, zbrn, zhelp1, zhelp2, zhelp3, zhelp4, & !$acc dzeta_dlam, dzeta_dphi, wgtfac, zhelp2d, zpres, & !$acc zcape_mu, zcin_mu, zcape_ml, zcin_ml, zlcl_ml, & !$acc zlfc_ml, zcape_3km, zgsp, zenith_t, zenith_w, & !$acc pdot, zenith_h, zrlatdeg, zrlondeg, zuspdd, zvspdd) !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE organize_output !============================================================================== !+ distributes records to PEs and packs them into grib format !------------------------------------------------------------------------------ SUBROUTINE output_data (nuedat, irec, i1,i2,i3, k, klevels, iaee, & array2d_real, outblock, lflush, yextension, slev, & lrestart, incdf_var_id, var_index, my_orgdata, & idebug, lacc) !------------------------------------------------------------------------------ ! ! Description: ! output_data distributes records to the PEs for packing these into ! grib format. First, the records are only gathered from all PEs and ! every PE stores one record into the variable procarray_xxx. Only if every ! PE has got a record, the data are packed and written to disk (in the ! routine "write_xxxx"). If some PEs have got no record because no more ! records are left, the output buffers (variable procarray_xx) are "flushed". ! ! Method: ! output_data is called for every record that is processed. The PE that ! gets a special record, saves the characteristics of this record for the ! output step later on. ! !------------------------------------------------------------------------------ ! Subroutine / Function arguments ! Scalar arguments with intent(in): INTEGER, INTENT (IN) :: & nuedat, & ! descriptor of the grib file irec, & ! number of record to be processed i1,i2,i3,& ! location of the variable in the LM variable table k, & ! number of the actual level klevels, & ! number of levels this variable has iaee, & ! to set additional element number for tile information idebug ! for verbosity debug output TYPE(pp_nl), INTENT(IN) :: & outblock ! pointer to the namelist group LOGICAL , INTENT (IN) :: & lflush, & ! for flushing the output buffers lrestart ! whether restart-files are written or not CHARACTER (LEN= 1) , INTENT (IN) :: & yextension ! to check which output list is processed REAL (KIND=wp) , INTENT (IN) :: & slev ! level for vertical interpolated fields ! has to be present for p- and z-levels ! Array arguments with intent(inout): REAL (KIND=wp) , INTENT (INOUT) :: & array2d_real (ie,je) ! values of the variable to be processed INTEGER , INTENT(IN) :: & incdf_var_id ! NetCDF-ID of each variable in the output list ! only PE 0 has a reasonable value here INTEGER , INTENT(IN) :: & var_index ! index of the variable within list of variables for ! current gribout INTEGER , INTENT(INOUT) :: & my_orgdata(4,0:num_compute-1) ! necessary only for PE 0 to save information REAL(KIND=sp), ALLOCATABLE :: ds_single(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: & lacc ! flag to run on GPU !------------------------------------------------------------------------------ ! ! Local variables: ! Local scalars: INTEGER (KIND=intgribf) :: iz_ps=1, izerrf INTEGER (KIND=intgribf) :: ierrf, my_k_f, my_iee INTEGER :: npe, iz_lfd, izstat, izerror, i,j, ij_ful, iz_lfa, & irecord_len, ij_out, nzjulianday, ncenter_save INTEGER :: irec2, npe2, nztri, n, nztable, nzuot, nzlastout INTEGER (KIND=int_ga) :: irecord_lga ! length of grib record REAL (KIND=wp) :: zavgfactor, z2, ztgranul, zacthour REAL (KIND=wp) :: zbias, zgribfactor, array2dreal(ie_max, je_max) REAL (KIND=irealgrib) :: array2dgrib(ie_max,je_max), & ds_out(ie_tot*je_tot), undefsub REAL (KIND=dp) :: ds_api(ie_tot*je_tot) REAL (KIND=wp) :: missingValue CHARACTER (LEN=25) :: yroutine CHARACTER (LEN=80) :: yerrmsg CHARACTER (LEN=clen) :: yzname CHARACTER (LEN=14) :: yzdatact CHARACTER (LEN=28) :: yzdat2 INTEGER , SAVE :: my_i1, my_i2, my_i3, my_k, my_irec, my_uot, my_lastout, my_aee LOGICAL , SAVE :: loutput REAL (KIND=wp) , SAVE :: rmy_slev INTEGER , SAVE :: low_irec, high_irec ! Local arrays: #ifdef NETCDF INTEGER , SAVE :: & my_orgdata_asyn( nc_orgmdata_length ), & ! array with metadata of netcdf file my_vardata_asyn( nc_varmdata_length ) ! array with metadata of variable being sent #endif REAL (KIND=wp), ALLOCATABLE, SAVE :: & procarray_real (:,:,:), & procarray2d_real(:,:,:) REAL (KIND=irealgrib), ALLOCATABLE, SAVE :: & procarray_grib (:,:,:), & procarray2d_grib(:,:,:) INTEGER, DIMENSION(0:num_compute-1) :: sendcnts, sdispls, recvcnts, rdispls #ifdef GRIBAPI INTEGER (KIND=kindOfSize) :: ibyte_size_out #endif LOGICAL :: lzacc !- End of header !============================================================================== !------------------------------------------------------------------------------ ! Section 1: Initializations !------------------------------------------------------------------------------ #ifdef MESSY IF (.NOT. l_COSMO_now) RETURN #endif IF (PRESENT(lacc)) THEN lzacc = lacc ELSE lzacc = .FALSE. ENDIF !$acc data present (array2d_real) if (lzacc) !$acc update host (array2d_real) if (lzacc) !$acc end data IF (idebug > 15) THEN WRITE (*,'(A,3I6)') ' src_output: entering output_data', i1, i2, i3 ENDIF yroutine = 'output_data' yzname = ' ' izerror = 0 izerrf = 0_intgribf iz_lfd = INT (lfd) iz_lfa = INT (lfa) ! set undef values IF (outblock%yform_write /= 'ncdf' .AND. outblock%yform_write /= 'nc-4') THEN undef = REAL(undefgrib, wp) undefsub = undefgrib ELSE undef = REAL(undefncdf, wp) undefsub = undefncdf ENDIF ! security check on itype_gather IF (itype_gather /= 1 .AND. itype_gather /= 2) THEN WRITE(*,*) 'ERROR: INVALID itype_gather IN output_data ' ENDIF ! allocate buffer memory IF (lrestart) THEN IF ( .NOT. ALLOCATED(procarray_real) ) THEN ALLOCATE(procarray_real(ie_max, je_max, num_compute), STAT=izstat) izerror = izerror + izstat ENDIF IF ( (itype_gather == 2) .AND. (.NOT. ALLOCATED(procarray2d_real)) ) THEN ALLOCATE(procarray2d_real(ie_max, je_max, num_compute), STAT=izstat) izerror = izerror + izstat ENDIF ELSE IF ( .NOT. ALLOCATED(procarray_grib) ) THEN ALLOCATE(procarray_grib(ie_max, je_max, num_compute), STAT=izstat) izerror = izerror + izstat ENDIF IF ( (itype_gather == 2) .AND. (.NOT. ALLOCATED(procarray2d_grib)) ) THEN ALLOCATE(procarray2d_grib(ie_max, je_max, num_compute), STAT=izstat) izerror = izerror + izstat ENDIF ENDIF IF (izerror /= 0) THEN WRITE(*,*) 'ERROR: PROBLEM ALLOCATING MEMORY IN output_data' ENDIF ! setup house keeping data for all2allv gathering IF (irec == 1) THEN my_orgdata(:,:) = 0 loutput = .FALSE. low_irec = 1 high_irec = 1 ENDIF IF ( low_irec == 0 .AND. .NOT. lflush ) low_irec = irec ! if just flushed IF ( .NOT. lflush ) high_irec = MAX(high_irec,irec) !------------------------------------------------------------------------------ ! Section 2: If this is not a call to only flush the output data, ! gather the field on the next free PE !------------------------------------------------------------------------------ IF (.NOT. lflush) THEN IF (idebug > 15) THEN WRITE (*,'(A,3I6)') ' src_output: gather field on next free task', i1, i2, i3 ENDIF ! Get the number of the PE to deal with that slice npe = MOD(irec-1,num_compute) #ifdef NETCDF my_orgdata_asyn(1) = cur_outstep_idx SELECT CASE ( yextension ) CASE('c') my_orgdata_asyn(2) = 0 CASE(' ') my_orgdata_asyn(2) = 1 CASE('p') my_orgdata_asyn(2) = 2 CASE('z') my_orgdata_asyn(2) = 3 CASE('s') my_orgdata_asyn(2) = 4 END SELECT my_orgdata_asyn(3) = cur_gribout_idx #endif ! Save necessary values for later processing IF (my_cart_id == npe ) THEN my_irec = irec my_i1 = i1 my_i2 = i2 my_i3 = i3 my_k = k my_aee = iaee rmy_slev = slev loutput = .TRUE. #ifdef NETCDF my_vardata_asyn(1) = var_index my_vardata_asyn(2) = k my_vardata_asyn(3) = klevels #endif ENDIF #ifdef NETCDF ! Processor 0 has to save some organizational data IF (my_cart_id == 0) THEN my_orgdata(1,npe) = k my_orgdata(2,npe) = klevels my_orgdata(3,npe) = incdf_var_id my_orgdata(4,npe) = iaee ENDIF #endif ! for fields with statistical processing: get entry in table list_stat_proc nztri = var(i1,i2,i3)%ntri IF (nztri >= 2) THEN search_uot: DO n = 1, idim_tsp IF (TRIM(list_stat_proc(n)%yname) == TRIM(var(i1,i2,i3)%name)) THEN nztable = n EXIT search_uot ENDIF ENDDO search_uot ENDIF ! set my_lastout and my_uot (unit of time range) ! either from GRIBOUT group or table of fields for statistical processing nzuot = outblock%nunit_of_time IF (.NOT. lrestart) THEN !US IF ( (nztri >= 2) .AND. (.NOT. lbdclim) ) THEN IF (nztri >= 2) THEN nzlastout = list_stat_proc(nztable)%nlastout IF (list_stat_proc(nztable)%itype_reset == 2) THEN nzuot = list_stat_proc(nztable)%nuot ENDIF ELSE IF (outblock%nextstep == 1) THEN nzlastout = 0 ! Adaptation, if summation and meanvalues are done between output steps ! and the first output step is not 0 IF (outblock%ngrib( outblock%nextstep) > 0 ) THEN nzlastout = outblock%ngrib( outblock%nextstep ) - & (outblock%ngrib( outblock%nextstep+1 )-outblock%ngrib( outblock%nextstep )) !US should it be: nzlastout = outblock%ngrib( outblock%nextstep) ??????? ENDIF ELSE nzlastout = outblock%ngrib( outblock%nextstep-1 ) ENDIF ENDIF ELSE ! nzlastout = outblock%nextstep - nhour_restart(3) * NINT (3600.0_wp / dt) nzlastout = outblock%ngrib(outblock%nextstep) - nhour_restart(3) * NINT (3600.0_wp / dt) ENDIF ! Save necessary values for later processing (my_uot, my_lastout) IF (my_cart_id == npe ) THEN my_lastout = nzlastout my_uot = nzuot ENDIF ! scale the fields with time range indicator 3 !US-ACHTUNG: this has to be adapted to GRIB2 somehow!!! IF ((.NOT. lrestart) .AND. (var(i1,i2,i3)%ntri == 3) ) THEN IF (ntstep == 0) THEN zavgfactor = 1.0_wp ELSE IF (lbdclim) THEN ! averaging is done between output steps zavgfactor = 1.0_wp / REAL (ntstep - nzlastout, wp) ELSE ! averaging is done between beginning of forecast and ! actual output step IF (l2tls) THEN zavgfactor = 1.0_wp / REAL (ntstep+1, wp) ELSE zavgfactor = 1.0_wp / REAL (ntstep, wp) ENDIF ENDIF ENDIF DO j = jstartpar, jendpar DO i = istartpar, iendpar ! handle the mean wind speed in single sector classes, only account for ! time period where wind was really active in this sector IF ( TRIM(var(i1,i2,i3)%name) == 'SP_10M_SECAV' ) THEN ! cannot be in one IF statement, because for other fields k might be bigger ! than defined for wdirgeo_10m_freq: gives out-of-bounds error IF ( wdirgeo_10m_freq(i,j,k) > 0.0_wp) THEN array2d_real(i,j) = array2d_real(i,j) / wdirgeo_10m_freq(i,j,k) ELSE !US what to do here? array2d_real(i,j) = 0.0_wp ENDIF ELSE array2d_real(i,j) = array2d_real(i,j) * zavgfactor ENDIF ENDDO ENDDO ENDIF ! Scale field with factor and bias (only for grib) ! transform it to single precision (for grib and Netcdf) zbias = var(i1,i2,i3)%bias zgribfactor = var(i1,i2,i3)%factor ! Note: (array2d_real is input to this routine, with dimensions (ie,je) ! The following fields are set below and are used for communications ! array2dreal (ie_max,je_max) is used for restart output (bina, ncdf) ! array2dgrib (ie_max,je_max) is used for output with grb1 api(1,2) and ncdf ! (but not restart with ncdf) IF (outblock%yform_write == 'grb1' .OR. outblock%yform_write(1:3) == 'api') THEN ! Check for undefined values in case of NetCDF-Input and Grib output IF (yform_read == 'ncdf' .OR. yform_read == 'nc-4') THEN ! this is a very pragmatic solution, which might not be satisfactory DO j = jstartpar, jendpar DO i = istartpar, iendpar IF (array2d_real(i,j) == REAL(undefncdf, wp)) THEN array2d_real(i,j) = 0.0_wp ENDIF ENDDO ENDDO ENDIF DO j = jstartpar, jendpar DO i = istartpar, iendpar ! Do an additional clipping, if values are too small IF (ABS(array2d_real(i,j)) < 1.0E-15_wp) THEN array2dgrib(i,j) = & REAL (((0.0_wp + zbias) * zgribfactor), irealgrib) ELSE array2dgrib(i,j) = & REAL (((array2d_real(i,j) + zbias) * zgribfactor), irealgrib) ENDIF ENDDO ENDDO ELSEIF (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4') THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar ! No scaling for NetCDF and Restart Files (in netcdf) IF (.NOT. lrestart) THEN array2dgrib(i,j) = REAL (array2d_real(i,j), irealgrib) ELSE ! fill array2dreal also for yform_write=ncdf and lrestart array2dreal(i,j) = array2d_real(i,j) ENDIF ENDDO ENDDO ! take care of special fields ! we can skip this whole block for restart output IF (.NOT. lrestart) THEN IF (var(i1,i2,i3)%lsm == 'l') THEN WHERE (.NOT. llandmask(1:ie,1:je)) array2dgrib(1:ie,1:je) = undefncdf ENDIF IF (var(i1,i2,i3)%lsm == 's') THEN WHERE (llandmask(1:ie,1:je)) array2dgrib(1:ie,1:je) = undefncdf ENDIF IF (var(i1,i2,i3)%lsm == 'i') THEN WHERE (fr_lake(1:ie,1:je) <= 0.5_wp) array2dgrib(1:ie,1:je) = undefncdf ENDIF IF (TRIM(var(i1,i2,i3)%name) == 'SNOWLMT' .OR. & TRIM(var(i1,i2,i3)%name) == 'HZEROCL' .OR. & ! CLM (Burkhardt) TRIM(var(i1,i2,i3)%name) == 'CIN_MU' .OR. & TRIM(var(i1,i2,i3)%name) == 'CIN_ML' .OR. & !BR!!! TRIM(var(i1,i2,i3)%name) == 'CAPU_MU' .OR. & TRIM(var(i1,i2,i3)%name) == 'CAPE_MU' .OR. & TRIM(var(i1,i2,i3)%name) == 'CAPE_ML') THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar ! IF (array2dgrib(i,j) == -999.0_irealgrib) THEN ! CLM (Burkhardt) IF (array2dgrib(i,j) == -999.0_irealgrib .OR. array2dgrib(i,j) == -999.9_irealgrib) THEN array2dgrib(i,j) = undefncdf ENDIF ENDDO ENDDO ENDIF IF (TRIM(var(i1,i2,i3)%name) == 'HBAS_CON' .OR. & TRIM(var(i1,i2,i3)%name) == 'HTOP_CON') THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar IF (array2dgrib(i,j) == 0.0_irealgrib) THEN array2dgrib(i,j) = undefncdf ENDIF ENDDO ENDDO ENDIF IF (TRIM(var(i1,i2,i3)%name) == 'T_SNOW') THEN ! we are working on tile iaee: therefore check this tile for w_snow DO j = jstartpar, jendpar DO i = istartpar, iendpar IF (w_snow(i,j,iaee,nnow) == 0.0_wp) THEN array2dgrib(i,j) = undefncdf ENDIF ENDDO ENDDO ENDIF IF (TRIM(var(i1,i2,i3)%name) == 'Z0') THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar array2dgrib(i,j) = array2dgrib(i,j) * 0.10197_irealgrib ENDDO ENDDO ENDIF ! CLM (Ronny) IF ( TRIM(var(i1,i2,i3)%name) == 'DD_10M' ) THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar IF ( array2dgrib(i,j) == undefgrib ) THEN array2dgrib(i,j) = undefncdf ENDIF ENDDO ENDDO ENDIF IF ( TRIM(var(i1,i2,i3)%name) == 'SP_10M_SECMAX' ) THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar IF ( array2dgrib(i,j) <= 1.0e-10_wp ) THEN !the initialized value (zero) was not changed array2dgrib(i,j) = undefncdf ENDIF ENDDO ENDDO ENDIF IF ( TRIM(var(i1,i2,i3)%name) == 'SP_10M_SECAV' ) THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar IF ( array2dgrib(i,j) <= 1.0e-10_wp ) THEN !the initialized value (zero) was not changed, !the next possible value is 0.3 (speed threshold) array2dgrib(i,j) = undefncdf ENDIF ENDDO ENDDO ENDIF ENDIF !lrestart ELSEIF (outblock%yform_write == 'bina') THEN DO j = jstartpar, jendpar DO i = istartpar, iendpar ! no scaling and converting in case of restart files, ! because this is not reproducible! array2dreal(i,j) = array2d_real(i,j) ENDDO ENDDO ENDIF IF ( ldebug_io .AND. (idbg_level >= 10) .AND. (my_cart_id == npe)) THEN PRINT *, ' src_output: gathering ', TRIM(var(my_i1, my_i2, my_i3)%name), my_k, my_aee, & ' to PE ', npe ENDIF ! Save data if num_compute=1 or for all2allv gathering IF (num_compute == 1) THEN ! no need to gather data, simply save IF (lrestart) THEN procarray_real(:,:,1) = array2dreal(:,:) ELSE procarray_grib(:,:,1) = array2dgrib(:,:) ENDIF ELSE ! for all2allv gathering we need to store data IF (itype_gather == 2) THEN IF (lrestart) THEN procarray2d_real(:,:,npe+1) = array2dreal(:,:) ELSE procarray2d_grib(:,:,npe+1) = array2dgrib(:,:) ENDIF ENDIF ENDIF ENDIF IF (ltime) CALL get_timings (i_computations_O, ntstep, dt, izerror) !------------------------------------------------------------------------------ ! Section 3: Gather full vertical levels onto compute PEs !------------------------------------------------------------------------------ IF (num_compute > 1) THEN ! Gather the data using MPI_GATHER for each vertical level individually IF ( (itype_gather == 1) .AND. (.NOT. lflush) ) THEN IF (.NOT. lrestart) THEN CALL gather_values (array2dgrib, procarray_grib, ie_max, je_max, & num_compute, imp_grib, npe, icomm_cart, yerrmsg, izerror) ELSE CALL gather_values (array2dreal, procarray_real, ie_max, je_max, & num_compute, imp_reals, npe, icomm_cart, yerrmsg, izerror) ENDIF ENDIF ! Gather the data using MPI_ALL2ALLV for a maximum of num_compute vertical levels IF ( (itype_gather == 2) .AND. & (lflush .OR. MOD(irec-1,num_compute) == num_compute-1) ) THEN IF (low_irec > 0 .AND. high_irec >= low_irec ) THEN ! Initialize send counts and receive counts sendcnts(:) = 0 sdispls(:) = 0 recvcnts(:) = 0 rdispls(:) = 0 ! Setup receive counts if this PE should receive a field IF (loutput) THEN DO npe2 = 0, num_compute-1 recvcnts(npe2) = ie_max*je_max rdispls(npe2) = npe2*ie_max*je_max ENDDO ENDIF ! Setup send counts for all PEs DO irec2 = low_irec, high_irec npe2 = MOD(irec2-1, num_compute) sendcnts(npe2) = ie_max*je_max sdispls(npe2) = npe2*ie_max*je_max ENDDO ! Do all2allv for gather the data on the receiving PEs IF (lrestart) THEN CALL MPI_ALLTOALLV(procarray2d_real,sendcnts,sdispls, & imp_reals,procarray_real,recvcnts, & rdispls, imp_reals,icomm_cart,izerror) ELSE CALL MPI_ALLTOALLV(procarray2d_grib,sendcnts,sdispls, & imp_grib,procarray_grib,recvcnts, & rdispls, imp_grib,icomm_cart,izerror) ENDIF ! Reset record counters low_irec = 0 high_irec = -1 ENDIF ENDIF IF (ltime) CALL get_timings (i_gather_data, ntstep, dt, izerror) ENDIF !------------------------------------------------------------------------------ ! Section 4: If lflush is .TRUE. or all PEs have gotten data, do the output !------------------------------------------------------------------------------ IF ( lflush .OR. MOD(irec-1,num_compute) == num_compute-1) THEN IF (idebug > 15) THEN WRITE (*,'(A,3I6)') ' src_output: flush the buffers', my_i1, my_i2, my_i3 ENDIF !--------------------------------------------------------------------------- ! Section 4.1: All PEs that have gotten data must combine the subarrays ! and convert data to GRIB !--------------------------------------------------------------------------- IF ( loutput ) THEN IF (outblock%yform_write /= 'ncdf' .AND. outblock%yform_write /= 'nc-4') THEN IF (ltime) CALL get_timings (i_computations_O, ntstep, dt, izerror) IF (idebug > 15) THEN WRITE (*,'(A)') ' src_output: complete grib meta data' ENDIF #ifdef GRIBAPI IF (outblock%yform_write(1:3) == 'api') THEN CALL grib_clone(outblock%igribapi_id, igribid, izerrf) IF (izerrf /= GRIB_SUCCESS) THEN PRINT *, ' *** Error in grib_clone: from outblock sample ', izerrf ENDIF ENDIF #endif CALL make_grib_grid (outblock, igribid, my_i1,my_i2,my_i3, yextension, idebug) ! Determine the reference time IF (outblock%lanalysis) THEN ! When nudging is active the output fields are treated as analyses ! and the reference time is the actual forecast time ! In principle we could use yakdat1 to get the entries for grib meta data ! But when using a flexible dt, the hour has eventually to be updated ! to the nearest output step (which should be a multiple of 0.25 h = 900.0 s ztgranul = 900.0_wp z2 = (REAL(ntstep, wp) * dt) / ztgranul IF (ABS(REAL(NINT(z2), wp) - z2) > 1.0E-5_wp) THEN ! determine date again with time step ztgranul and number of steps ! necessary (z2) to reach the same forecast time that wie have now. CALL get_utc_date(NINT(z2), ydate_ini, ztgranul, itype_calendar, yzdatact, & yzdat2, nzjulianday, zacthour) ELSE CALL get_utc_date(ntstep, ydate_ini, dt, itype_calendar, yzdatact, & yzdat2, nzjulianday, zacthour) ENDIF ELSE yzdatact(1:14) = ydate_ini(1:14) ENDIF CALL make_grib_product (outblock, igribid, my_i1,my_i2,my_i3, my_k, my_aee, & yzdatact, my_lastout, my_uot, yextension, rmy_slev, lrestart, idebug) ENDIF IF (ltime) CALL get_timings (i_meta_data_w, ntstep, dt, izerror) IF (.NOT. lrestart) THEN ! combine the subarrays in the correct order CALL combine_subarrays (procarray_grib, ds_grib) IF (ltime) CALL get_timings (i_gather_data, ntstep, dt, izerror) ! Extra smoothing of fi and pmsl in mountaineous regions: IF (outblock%l_fi_pmsl_smooth) THEN IF ( (var(my_i1,my_i2,my_i3)%name == 'PMSL ') & .OR. (var(my_i1,my_i2,my_i3)%name == 'PMSL_ANAI')) THEN CALL smooth_pmsl (ds_grib, hsurf_tot, ie_tot, je_tot ) ENDIF IF(var(my_i1,my_i2,my_i3)%name == 'FI ') THEN CALL smooth_geopot (ds_grib, hsurf_tot, ie_tot, je_tot ) ENDIF ENDIF ! Possibility for independently smoothing of PMSL, ! decoupled from switch outblock%l_z_filter: ! (Note: PMSL is a variable in the group of model-levels!) IF (outblock%l_pmsl_filter) THEN IF ( (var(my_i1,my_i2,my_i3)%name == 'PMSL ') & .OR. (var(my_i1,my_i2,my_i3)%name == 'PMSL_ANAI')) THEN CALL smoother(ds_grib, ie_tot, je_tot, 4,20 ) ENDIF ENDIF ! Possibility for independently smoothing of interplated geopotential FI, ! decoupled from general smoothing or not on p- or z-levels: IF (outblock%l_fi_filter) THEN IF(var(my_i1,my_i2,my_i3)%name == 'FI ') THEN IF ( .NOT.(yextension == 'p' .AND. outblock%l_p_filter) .AND. & .NOT.(yextension == 'z' .AND. outblock%l_z_filter) ) THEN CALL smoother(ds_grib, ie_tot, je_tot, 4,20 ) ! .. Otherwise smoothing will be done a few lines below END IF ENDIF ENDIF ! Apply a digital smoother for selected fields IF(yextension == 'p' .AND. outblock%l_p_filter) THEN CALL smoother(ds_grib, ie_tot, je_tot, 4,20 ) ENDIF IF(yextension == 'z' .AND. outblock%l_z_filter) THEN CALL smoother(ds_grib, ie_tot, je_tot, 4,20 ) ENDIF ! Apply a neighbourhood criterion to filter the lightning potential index: ! The threshold 1.1 m/s for the neighbourhood wmax filtering has been ! determined by inspecting COSMO-DE simulations (2.8 km resolution) from 3 weeks in summer 2014. IF(TRIM(var(my_i1,my_i2,my_i3)%name) == 'LPI' .AND. itype_gscp >= 4) THEN IF (sp == irealgrib) THEN CALL lpi_spatial_filter ( ds_grib, REAL(wmax_tot,kind=wp), 1.1_wp, REAL(buo_tot,kind=wp), & ie_tot, je_tot, nboundlines, & dlon, dlat, startlat_tot, r_earth ) ELSE ALLOCATE (ds_single(ie_tot,je_tot)) ds_single = RESHAPE(REAL(ds_grib, kind=sp), (/ie_tot, je_tot/)) CALL lpi_spatial_filter ( ds_single, REAL(wmax_tot,kind=wp), 1.1_wp, REAL(buo_tot,kind=wp), & ie_tot, je_tot, nboundlines, & dlon, dlat, startlat_tot, r_earth ) ds_grib = REAL(RESHAPE(ds_single, (/ie_tot*je_tot/)),kind=wp) DEALLOCATE(ds_single) END IF ENDIF ! Limit certain variables to the allowed range (again) SELECT CASE (var(my_i1,my_i2,my_i3)%name) CASE ('RELHUM ') ds_grib(:) = MAX (0.0_irealgrib, MIN(100.0_irealgrib,ds_grib(:))) CASE ('QV ','QC ','QI ', & 'QR ','QS ','QG ', & 'QH ','NCCLOUD ','NCICE ', & 'NCRAIN ','NCSNOW ','NCGRAUPEL ','NCHAIL ','NCN_DIAG ' ) ds_grib(:) = MAX (0.0_irealgrib, ds_grib(:)) END SELECT ! Now cut out the proper (sub-)field which was chosen with ! slon, slat, elon, elat ij_out = 0 DO j = outblock%j_out_start, outblock%j_out_end DO i = outblock%i_out_start, outblock%i_out_end ij_out = ij_out+1 ij_ful = (j-1) * ie_tot + i ds_out(ij_out) = ds_grib(ij_ful) ds_api(ij_out) = REAL(ds_grib(ij_ful), dp) ENDDO ENDDO IF (ltime) CALL get_timings (i_computations_O, ntstep, dt, izerror) IF (outblock%yform_write == 'grb1') THEN #ifdef GRIBDWD !GRIB1 HACK: In case of COSMO_LEPS (or any ensemble) and usage of libdwd the ! centre has to be 78! ! Therefore override the centre ipds_out(3) temporarily with 78 (DWD) IF (leps .AND. iepstyp == 203 .AND. ipds_out (3) /= 78) THEN ncenter_save = ipds_out(3) ipds_out(3) = 78 ENDIF ! degrib the level CALL grbex1(idwdednr, iz_ps, undefgrib, ndims, idims_out, ipds_out, & igds_out, ibms, ibds, ibmap, dsup, ds_out, iblock, ierrf) IF (ierrf /= 0) THEN yerrmsg = 'error in grbex1' CALL model_abort (my_cart_id, 2022, yerrmsg, yroutine) ENDIF IF (leps .AND. iepstyp == 203 .AND. ipds_out (3) /= 78) THEN ipds_out(3) = ncenter_save ENDIF ! length of GRIB record in bytes irecord_len = idims_out(19) irecord_lga = INT (idims_out(19), int_ga) #endif #ifdef GRIBAPI ELSEIF (outblock%yform_write(1:3) == 'api') THEN ! Enable bitmap compression of special missing values for some variables: SELECT CASE (TRIM(var(my_i1,my_i2,my_i3)%name)) CASE ('ECHOTOP', 'ECHOTOPinM') missingValue = -999.0_wp CALL grib_set(igribid, 'missingValue', REAL(missingValue, dp)) ! data type dp is consistent to src_output.f90 (ds_api) CALL grib_set(igribid, 'bitmapPresent', 1) END SELECT CALL grib_set (igribid, 'values', ds_api(1:ij_out), izerrf) IF (izerrf /= GRIB_SUCCESS) THEN yerrmsg = 'error in grib_set: values' CALL model_abort (my_cart_id, 2022, yerrmsg, yroutine) ENDIF ! length of GRIB record in bytes CALL grib_get_message_size(igribid, ibyte_size_out, izerrf) IF (ibyte_size_out <= lfa) THEN CALL grib_get(igribid, 'totalLength', irecord_lga) CALL grib_copy_message(igribid, ymessage) ELSE yerrmsg = 'error with message length: ymessage too small: ' CALL model_abort (my_cart_id, 2022, yerrmsg, yroutine) ENDIF #endif ELSE ! length of netcdf record in words irecord_len = outblock%ie_out_tot * outblock%je_out_tot ENDIF IF (ltime) CALL get_timings (i_meta_data_w, ntstep, dt, izerror) ELSE ! this is for restart-output CALL combine_subarrays (procarray_real, ds_real) IF (ltime) CALL get_timings (i_gather_data, ntstep, dt, izerror) ! length of restart record in words irecord_len = outblock%ie_out_tot * outblock%je_out_tot ENDIF ELSE ! no output for this task irecord_len = 0 irecord_lga = 0_int_ga ds_real(:) = 0.0_wp IF (ltime) CALL get_timings (i_computations_O, ntstep, dt, izerror) ENDIF !--------------------------------------------------------------------------- ! Section 4.2: Check data and write output to disk !--------------------------------------------------------------------------- ! check the data, if wanted IF (outblock%lcheck .AND. (.NOT. lrestart)) THEN my_k_f = INT (my_k, intgribf) my_iee = INT (my_i2, intgribf) IF (.NOT. loutput) THEN my_i1 = 1; my_i2 = 1; my_i3 = 1 ! for safety reasons ENDIF CALL check_record (ds_grib, 1, ie_tot, 1, je_tot, 1, 1, & outblock%i_out_start, outblock%i_out_end, & outblock%j_out_start, outblock%j_out_end, 1, 1, & undefsub, var(my_i1,my_i2,my_i3)%name, & my_iee, my_k_f, my_aee, loutput, nuchkdat, num_compute, & icomm_cart, my_cart_id, yerrmsg, izerror) ELSEIF (lrestart) THEN IF ( ((TRIM(var(my_i1,my_i2,my_i3)%name) == 'T_SO') .OR. & (TRIM(var(my_i1,my_i2,my_i3)%name) == 'T_SO_SAVE')) .AND. & (outblock%yform_write == 'ncdf' .OR. outblock%yform_write == 'nc-4')) THEN my_k_f = INT(my_k-1, intgribf) ELSE my_k_f = INT (my_k, intgribf) ENDIF my_iee = INT (my_i2, intgribf) IF (.NOT. loutput) THEN my_i1 = 1; my_i2 = 1; my_i3 = 1 ! for safety reasons ENDIF ds_grib(:) = REAL (ds_real(:), irealgrib) CALL check_record (ds_grib, 1, ie_tot, 1, je_tot, 1, 1, 1, ie_tot, 1, & je_tot, 1, 1, undefsub, var(my_i1,my_i2,my_i3)%name, & my_iee, my_k_f, my_aee, loutput, nuchkdat, num_compute, & icomm_cart, my_cart_id, yerrmsg, izerror) ENDIF IF (ltime) CALL get_timings (i_computations_O, ntstep, dt, izerror) #ifdef MESSY IF (l_COSMO_now) THEN #endif SELECT CASE (outblock%yform_write) CASE ('grb1') #ifdef GRIBDWD CALL write_grib (nuedat, iblock, irecord_lga, iz_lfd, icomm_cart, & num_compute, lflush, lasync_io, ltime_barrier, & yerrmsg, izerror) #endif CASE ('api1','api2') #ifdef GRIBAPI CALL write_gribapi (nuedat, ymessage, irecord_lga, iz_lfa, num_compute, & icomm_cart, lflush, lasync_io, ltime_barrier, & yerrmsg, izerror) #endif CASE ('ncdf','nc-4') #ifdef NETCDF IF ( nc_asyn_io > 0 .AND. (.NOT. lrestart)) THEN CALL send_asyn_io ( ds_out, irecord_len, my_orgdata_asyn, & my_vardata_asyn, outblock,outblock%ie_out_tot, & outblock%je_out_tot, lflush,yerrmsg, izerror ) ELSE IF (lrestart) THEN IF (wp == sp) THEN ! write_netcdf then works with ds_grib ds_grib(:) = REAL (ds_real(:), irealgrib) ! should be the same precision ENDIF CALL write_netcdf (nuedat, ds_grib, ds_real, outblock%ie_out_tot, & outblock%je_out_tot, irecord_len, my_orgdata, & icomm_cart, my_cart_id, num_compute, imp_reals, & lasync_io, yerrmsg, izerror) ELSE !US here we have to pass the array, which has been cut out for a ! possible subdomain (ds_out) and NOT the full domain (ds_grib) !US CALL write_netcdf (nuedat, ds_grib, ds_real, outblock%ie_out_tot CALL write_netcdf (nuedat, ds_out, ds_api, outblock%ie_out_tot, & outblock%je_out_tot, irecord_len, my_orgdata, & icomm_cart, my_cart_id, num_compute, imp_grib, & lasync_io, yerrmsg, izerror) ENDIF ENDIF #endif CASE ('bina') CALL write_restart (nuedat, ds_real, ie_tot, je_tot, irecord_len, & ipds_out, npds, igds_out, ngds, icomm_cart, & my_cart_id, num_compute, imp_reals, lasync_io, & yerrmsg, izerror) END SELECT IF (izerror /= 0) THEN yerrmsg = TRIM(yerrmsg)//': '//TRIM(var(my_i1,my_i2,my_i3)%name) CALL model_abort (my_cart_id, 2035, yerrmsg, yroutine) ENDIF IF (ltime) CALL get_timings (i_write_data, ntstep, dt, izerror) IF ( ldebug_io .AND. (idbg_level >= 10 .AND. (my_cart_id == npe))) THEN PRINT *, ' src_output: saved ', TRIM(var(my_i1, my_i2, my_i3)%name), my_k, my_aee, ' to disk' ENDIF #ifdef MESSY ENDIF #endif ! Reset organizational variables #ifdef GRIBAPI IF (outblock%yform_write(1:3) == 'api') THEN CALL grib_release (igribid) ENDIF #endif my_orgdata(:,:) = 0 loutput = .FALSE. ! free memory IF (lrestart) THEN IF (ALLOCATED(procarray_real)) DEALLOCATE(procarray_real) IF (ALLOCATED(procarray2d_real)) DEALLOCATE(procarray2d_real) ELSE IF (ALLOCATED(procarray_grib)) DEALLOCATE(procarray_grib) IF (ALLOCATED(procarray2d_grib)) DEALLOCATE(procarray2d_grib) ENDIF ENDIF !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE output_data !============================================================================== !============================================================================== !+ Module procedure in src_output for the p-interpolation !------------------------------------------------------------------------------ SUBROUTINE p_int (outblock, i1,i2,i3, ylistname, idebug, results) !------------------------------------------------------------------------------ ! ! Description: ! This subroutine interpolates variables given in the namelist from ! model leves to pressure levels. The result of the interpolation ! is given back to the calling procedure in the three dimensional variable ! "results". ! ! Method: ! Column wise interpolation with tension splines. ! For the interpolation of FI and QV the logarithm of the pressure is ! used. ! !------------------------------------------------------------------------------ ! Subroutine / Function arguments ! Scalar arguments with intent(in): TYPE(pp_nl) , INTENT(IN) :: & outblock ! pointer to the namelist group INTEGER , INTENT(IN) :: & i1,i2,i3, & ! location of the variable to be processed in the LM ! variable table idebug ! for debug output CHARACTER (LEN=*) :: ylistname ! Array arguments with intent(out): REAL (KIND=wp), INTENT(OUT):: & results(ie,je,outblock%kepin) !------------------------------------------------------------------------------ ! ! Local parameters REAL(KIND=wp), PARAMETER :: gamma = 5.5_wp ! tension factor REAL(KIND=wp), PARAMETER :: delpchk = 1.0_wp ! Local scalars: INTEGER :: i, j, k, kint(ie,je) INTEGER :: jcstart, jcend !compute start end !indices in j direction #ifndef _OPENACC INTEGER :: jb ! index used for block optimization on CPU #endif INTEGER :: ierrstat, ierr, izlen INTEGER :: nldim(ie,je) REAL(KIND=wp) :: zt0s, zalnp, zpexp CHARACTER (LEN=25) :: yroutine CHARACTER (LEN=80) :: yerrmsg CHARACTER (LEN=clen) :: yzname ! Local arrays: REAL(KIND=wp) :: fmfl(ie,je,ke) REAL(KIND=wp) :: fexp(ie,je,ke+4), & pexp(ie,je,ke+4) REAL(KIND=wp) :: zdelp(ie,je) REAL(KIND=wp) :: ztstar(ie,je), zalpha(ie,je), zt0(ie,je) ! Output from tautsp3D REAL(KIND=wp) :: s_vec (ie,je,(ke+4)*6), & break_vec(ie,je,(ke+4)*3), & coef_vec (ie,je,4,(ke+4)*3) ! Output from spline REAL(KIND=wp) :: pfls (ie,je,outblock%kepin) REAL(KIND=wp) :: zhelp1(ie,je,ke), & zhelp2(ie,je,ke) ! Switch to choose between vertical interpolation methods: ! Local value; there is a global namelist parameter itype_vertint ! in each namelist of group GRIBOUT. INTEGER :: zitype_vertint ! Pointer and local variables needed for OpenACC port of derived types REAL(KIND=wp) :: pexp_min, zplev_kepin INTEGER :: itl_loc !- End of header !============================================================================== !------------------------------------------------------------------------------ ! Section 1: Set variable that has to be interpolated !------------------------------------------------------------------------------ yroutine = 'p_int' izlen = LEN_TRIM(ylistname) ! Spline interpolation is the default value, which may be changed for single fields below ! (e.g., if you would like to have splineinterpolation for all fiels but not for QC ...) zitype_vertint = outblock%itype_vertint ! calculation of u and v on masspoint ! ----------------------------------- #ifdef MESSY DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = 0.0_wp END DO END DO END DO #endif zvarp3_ptr => var(i1,i2,i3)%p3 zvarp4_ptr => var(i1,i2,i3)%p4 zvarp5_ptr => var(i1,i2,i3)%p5 itl_loc = itl #ifdef STATIC_FIELDS IF (var(i1,i2,i3)%lsm=='t') itl_loc = trcr_itl #endif !$acc data present( zvarp5_ptr, zvarp4_ptr, zvarp3_ptr, hhl, zqrs_itl, & !$acc zrho_itl, qi, p_anai, p0, pp, hsurf, ps, t, p0hl, results ) & !$acc create( fmfl, pexp, zdelp, fexp, kint, nldim, ztstar, zalpha, & !$acc zt0, pfls, s_vec, break_vec, coef_vec, zhelp1, zhelp2 ) IF (ylistname(1:izlen) == 'U' ) THEN !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=2,ie fmfl(i,j,k) = 0.5_wp * (zvarp4_ptr(i,j,k,itl) & + zvarp4_ptr(i-1,j,k,itl)) END DO END DO END DO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO k=1,ke DO j=1,je fmfl(1,j,k) = fmfl(2,j,k) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'V' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=2,je DO i=1,ie fmfl(i,j,k) = 0.5_wp * (zvarp4_ptr(i,j,k,itl) & + zvarp4_ptr(i,j-1,k,itl)) END DO END DO END DO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO k=1,ke DO i=1,ie fmfl(i,1,k) = fmfl(i,2,k) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'TKVM' .OR. ylistname(1:izlen) == 'TKVH') THEN ! are now rank=4 with tiles !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=2,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,0) END DO END DO END DO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,1) = fmfl(i,j,2) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'FI' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = 0.5_wp * ( hhl(i,j,k) + hhl(i,j,k+1) ) * g END DO END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'QRS' ) THEN IF (outblock%loutput_q_densities) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSE !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel END IF ELSEIF (ylistname(1:izlen) == 'Q_SEDIM') THEN IF (ASSOCIATED(qi)) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) - qi(i,j,k) END DO END DO END DO !$acc end parallel ELSE !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel ENDIF IF (outblock%loutput_q_densities) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = fmfl(i,j,k) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel END IF ELSEIF (ylistname(1:izlen) == 'RELHUM') THEN CALL calrelhum(fmfl(:,:,:), t(:,:,:,itl), pp(:,:,:,itl), p0(:,:,:), & qv(:,:,:),ie, je, ke, b1, b2w, b3, b4w, rdv, o_m_rdv, & lacc=.TRUE.) ELSEIF (ylistname(1:izlen) == 'OMEGA') THEN CALL calomega (fmfl(:,:,:), pp(:,:,:,nnew), pp(:,:,:,itl), pptens(:,:,:),& w(:,:,:,itl), rho0(:,:,:), ie, je, ke, dt, g, & lacc=.TRUE.) ! CLM added ELSEIF (ylistname(1:izlen) == 'VORTIC_W' ) THEN CALL curl (ie, je, ke, eddlon, eddlat, r_earth, acrlat, tgrlat, & sqrtg_r_s, dzeta_dlam, dzeta_dphi, lmetr, wgtfac, & u(:,:,:,itl ), v(:,:,:,itl ), w(:,:,:,itl ), & .TRUE., zhelp1(:,:,:), zhelp2(:,:,:), fmfl(:,:,:), lacc=.TRUE.) ELSEIF (ylistname(1:izlen) == 'TKE' ) THEN ! is now rank=5 with tiles SELECT CASE( itype_turb ) CASE( 5:8 ) !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp5_ptr(i,j,k,0,itl) END DO END DO END DO !$acc end parallel CASE DEFAULT !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = 0.5_wp * (zvarp5_ptr(i,j,k,0,itl))**2 END DO END DO END DO !$acc end parallel END SELECT ELSEIF (ylistname(1:izlen) == 'FI_ANAI' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = p_anai(i,j,k) / zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'QC' .OR. ylistname(1:izlen) == 'NCCLOUD' .OR. & ylistname(1:izlen) == 'QR' .OR. ylistname(1:izlen) == 'NCRAIN' .OR. & ylistname(1:izlen) == 'QI' .OR. ylistname(1:izlen) == 'NCICE' .OR. & ylistname(1:izlen) == 'QS' .OR. ylistname(1:izlen) == 'NCSNOW' .OR. & ylistname(1:izlen) == 'QG' .OR. ylistname(1:izlen) == 'NCGRAUPEL' .OR. & ylistname(1:izlen) == 'QH' .OR. ylistname(1:izlen) == 'NCHAIL') THEN IF (outblock%loutput_q_densities) THEN ! output as densities: !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl_loc) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSE ! output as mass specific: !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl_loc) END DO END DO END DO !$acc end parallel ENDIF #ifdef RADARFWO ELSEIF (ylistname(1:izlen) == 'DBZ') THEN #ifdef _OPENACC CALL model_abort(my_cart_id, ierrstat, "Error: EMVORADO not ported to GPU", yroutine) #endif CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), zh_radar_wp = fmfl) ! Reflectivity is now delivered in linear space by calc_dbz_vec_modelgrid(). ! This is where interpolation should be done, not in logarithmic space. ! (as alternative, interpolation in the space of rain rate -- Z^0.6666 --- ! would also be desireable): !UB ELSEIF (ylistname(1:izlen) == 'VTERM') THEN ELSEIF (ylistname(1:izlen) == 'DUMMY_1') THEN #ifdef _OPENACC CALL model_abort(my_cart_id, ierrstat, "Error: EMVORADO not ported to GPU", yroutine) #endif IF (luse_radarfwo) THEN CALL calc_fallspeed_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, lwdbz=lweightdbz, & ldebug=ldebug_io, vt_radar_wp=fmfl) ELSE CALL calc_fallspeed_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, lwdbz=.TRUE., & ldebug=ldebug_io, vt_radar_wp=fmfl) END IF !UB ELSEIF (ylistname(1:izlen) == 'EXT_DBZ') THEN ELSEIF (ylistname(1:izlen) == 'DUMMY_2') THEN #ifdef _OPENACC CALL model_abort(my_cart_id, ierrstat, "Error: EMVORADO not ported to GPU", yroutine) #endif CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), ah_radar_wp = fmfl) fmfl = 20.0e3_wp / LOG(10.0_wp) * fmfl #else ELSEIF (ylistname(1:izlen) == 'DBZ') THEN IF (itype_gscp == 3) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, idebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & z_radar = fmfl, lacc=.TRUE. ) ELSEIF (itype_gscp == 4) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, idebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & q_grau = zqg_itl(:,:,:), z_radar = fmfl, lacc=.TRUE.) #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 100) THEN DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) zqh_itl(i,j,k) = qh(i,j,k)*zrho_itl(i,j,k) zqnc_itl(i,j,k) = qnc(i,j,k)*zrho_itl(i,j,k) zqnr_itl(i,j,k) = qnr(i,j,k)*zrho_itl(i,j,k) zqni_itl(i,j,k) = qni(i,j,k)*zrho_itl(i,j,k) zqns_itl(i,j,k) = qns(i,j,k)*zrho_itl(i,j,k) zqng_itl(i,j,k) = qng(i,j,k)*zrho_itl(i,j,k) zqnh_itl(i,j,k) = qnh(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO CALL radar_sb_ray (ie, je, ke, pi, & klv850, my_cart_id, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), & zqi_itl(:,:,:), zqs_itl(:,:,:), & zqg_itl(:,:,:), zqh_itl(:,:,:), & zqnc_itl(:,:,:), zqnr_itl(:,:,:), & zqni_itl(:,:,:), zqns_itl(:,:,:), & zqng_itl(:,:,:), zqnh_itl(:,:,:), & z_radar = fmfl, lacc=.TRUE. ) #endif ENDIF ! Reflectivity is now delivered in linear space by radar_XX_ray(). ! This is where interpolation should be done, not in logarithmic space. ! (as alternative, interpolation in the space of rain rate -- Z^0.6666 --- ! would also be desireable): #endif ELSEIF ( ylistname(1:izlen) == 'PT' ) THEN ! potential temperature !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = t(i,j,k,itl) * & (p0ref/(p0(i,j,k)+pp(i,j,k,itl)))**(r_d/cp_d) END DO END DO END DO !$acc end parallel ELSEIF ( ylistname(1:izlen) == 'THETA_V' ) THEN ! virtual potential temperature !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = t(i,j,k,itl) * & (p0ref/(p0(i,j,k)+pp(i,j,k,itl)))**(r_d/cp_d) * & (1.0_wp + rvd_m_o * qv(i,j,k)) END DO END DO END DO !$acc end parallel ELSEIF ( ylistname(1:izlen) == 'DEN' ) THEN !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSE IF (var(i1,i2,i3)%idimvert < ke) THEN ! this variable cannot be interpolated to pressure levels yerrmsg = 'Variable cannot be interpolated to pressure levels: ' WRITE (yerrmsg(55:70), '(A16)') TRIM(var(i1,i2,i3)%name) ierrstat = 2004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ELSE SELECT CASE( var(i1,i2,i3)%rank ) CASE(4) IF (var(i1,i2,i3)%ltiles) THEN ! this is a 3D variable + tiles ! this is NOT a 2D variable with tiles and time dimension, ! because this would have idimvert < ke !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,0) END DO END DO END DO !$acc end parallel ELSE ! this is a 3D variable + time dimension !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl_loc) END DO END DO END DO !$acc end parallel ENDIF CASE(3) ! this is a 3D variable (no tiles, no time: because then idimvert < ke) !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp3_ptr(i,j,k) END DO END DO END DO !$acc end parallel END SELECT ENDIF ! idimvert < ke ENDIF !------------------------------------------------------------------------------ ! Section 2: Interpolation !------------------------------------------------------------------------------ ! slicewise interpolation ! ----------------------- ! Hardwired choice of linear interpolation for hydrometeors and DBZ to ! prevent spurious overshoots: IF ( ylistname(1:izlen) == 'QC' .OR. ylistname(1:izlen) == 'QR' .OR. & ylistname(1:izlen) == 'QI' .OR. ylistname(1:izlen) == 'QS' .OR. & ylistname(1:izlen) == 'QG' .OR. ylistname(1:izlen) == 'QH' .OR. & ylistname(1:3) == 'DBZ' .OR. & !UB ylistname(1:izlen) == 'EXT_DBZ' .OR. & ylistname(1:izlen) == 'DUMMY_2' .OR. & !UB ylistname(1:izlen) == 'VTERM' ) THEN ylistname(1:izlen) == 'DUMMY_1' ) THEN zitype_vertint = 2 END IF #ifdef TWOMOM_SB IF ( ylistname(1:izlen) == 'NCCLOUD' .OR. ylistname(1:izlen) == 'NCRAIN' .OR. & ylistname(1:izlen) == 'NCICE' .OR. ylistname(1:izlen) == 'NCSNOW' .OR. & ylistname(1:izlen) == 'NCGRAUPEL' .OR. ylistname(1:izlen) == 'NCHAIL' ) THEN zitype_vertint = 2 END IF #endif ! Calculation of the pressure at full model levels. ! Variables defined on half levels are first averaged to ! full levels. ! For water vapour (QV) and geopotential height (FI), the ! interpolation on constant pressure levels is logarithmic ! with respect to pressure. !Optimization : On CPU block loop going over all j points ! On GPU no blocking #ifndef _OPENACC !CPU DO jb=jstartpar,jendpar jcstart=jb jcend=jb #else !GPU jcstart=jstartpar jcend=jendpar #endif SELECT CASE(var(i1,i2,i3)%levtyp) CASE(110) IF (ylistname(1:izlen) == 'QV' .OR. & ylistname(1:izlen) == 'FI' .OR. & ylistname(1:izlen) == 'QV_ANAI' .OR. & ylistname(1:izlen) == 'FI_ANAI' ) THEN !$acc parallel !$acc loop gang vector collapse(3) DO k = 1, ke DO j=jcstart,jcend DO i = 1, ie pexp(i,j,k) = LOG(p0(i,j,k) + pp(i,j,k,itl)) ENDDO ENDDO ENDDO !$acc end parallel !$acc parallel copy( outblock ) copyin( outblock%plev(:) ) !$acc loop gang vector collapse(3) DO k = 1, outblock%kepin DO j=jcstart,jcend DO i = 1, ie pfls(i,j,k) = LOG(outblock%plev(k)) ENDDO ENDDO ENDDO !$acc end parallel ELSE !$acc parallel !$acc loop gang vector collapse(3) DO k = 1, ke DO j=jcstart,jcend DO i = 1, ie pexp(i,j,k) = p0(i,j,k) + pp(i,j,k,itl) ENDDO ENDDO ENDDO !$acc end parallel !$acc parallel copy( outblock ) copyin( outblock%plev(:) ) !$acc loop gang vector collapse(3) DO k = 1, outblock%kepin DO j=jcstart,jcend DO i = 1, ie pfls(i,j,k) = outblock%plev(k) ENDDO ENDDO ENDDO !$acc end parallel ENDIF CASE(109) !$acc parallel !$acc loop gang vector collapse(3) DO k = 2, ke DO j=jcstart,jcend DO i = 1, ie pexp(i,j,k) = p0hl(i,j,k) & + 0.5_wp*(pp(i,j,k,itl)+pp(i,j,k-1,itl)) ENDDO ENDDO ENDDO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i = 1, ie pexp(i,j,1) = p0hl(i,j,1) + pp(i,j,1,itl) ! best approximation we can get there ! before, this was used, but factor 0.5 is wrong ! + 0.5_wp *pp(i,j,1,itl) ENDDO ENDDO !$acc end parallel !$acc parallel copy( outblock ) copyin( outblock%plev(:) ) !$acc loop gang vector collapse(3) DO k = 1, outblock%kepin DO j=jcstart,jcend DO i = 1, ie pfls(i,j,k) = outblock%plev(k) ENDDO ENDDO ENDDO !$acc end parallel CASE DEFAULT yerrmsg = 'wrong leveltyp of input field' ierrstat = 2004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) END SELECT pexp_min = HUGE(1.0_wp) !$acc parallel !$acc loop gang vector collapse(2) reduction (min:pexp_min) DO j=jcstart,jcend DO i=1,ie IF (pexp(i,j,1) < pexp_min) THEN pexp_min = pexp(i,j,1) ENDIF ENDDO ENDDO !$acc end parallel ! Check if a plevel for interpolation is above the model top: IF ( MINVAL(outblock%plev(1:outblock%kepin)) <= pexp_min ) THEN yerrmsg = 'plev for interpolation above model top!' ierrstat = 1004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) END IF ! calculate pressure difference of lowest constant pressure level ! and surface pressure ! Workaround for OpenACC derived type zplev_kepin = outblock%plev(outblock%kepin) !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=1,ie zdelp(i,j) = zplev_kepin - ps(i,j,itl) END DO END DO !$acc end parallel ! vertical interpolation colum wise ! --------------------------------- ! copy slice variable to colum variable and set lowest modellevel !$acc parallel !$acc loop gang vector collapse(3) DO k = 1, ke DO j=jcstart,jcend DO i=istartpar,iendpar fexp(i,j,k) = fmfl(i,j,k) ENDDO ENDDO ENDDO !$acc end parallel IF (ylistname(1:izlen) == 'QV' .OR. & ylistname(1:izlen) == 'FI' .OR. & ylistname(1:izlen) == 'QV_ANAI' .OR. & ylistname(1:izlen) == 'FI_ANAI' ) THEN !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar fexp(i,j,ke+1) = fexp(i,j,ke) pexp(i,j,ke+1) = LOG(ps(i,j,itl)) ENDDO ENDDO !$acc end parallel ELSE !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar fexp(i,j,ke+1) = fexp(i,j,ke) pexp(i,j,ke+1) = ps(i,j,itl) ENDDO ENDDO !$acc end parallel ENDIF !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar IF (zdelp(i,j) > 0.0_wp) THEN kint(i,j) = ke + 4 ELSE kint(i,j) = ke + 1 ENDIF nldim(i,j) = (ke+4)*3 ENDDO ENDDO !$acc end parallel IF (TRIM(ylistname) == 'T') THEN !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend ! calculation of the soil temperature (ztstar) from the temperature ! of the lowest model level DO i=istartpar,iendpar ztstar(i,j) = t(i,j,ke,itl) + 0.0065_wp & * 0.5_wp*(hhl(i,j,ke)-hhl(i,j,ke+1)) zalpha(i,j) = 0.0065_wp*r_d/g zt0 (i,j) = ztstar(i,j) + 0.0065_wp * hsurf(i,j) ENDDO ENDDO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) private( zt0s ) DO j=jcstart,jcend DO i=istartpar,iendpar IF (ztstar(i,j) > 315.0_wp .AND. zt0(i,j) > 315.0_wp) THEN ztstar(i,j) = 0.5_wp * ( 315.0_wp + ztstar(i,j)) ELSEIF (ztstar(i,j) < 255.0_wp) THEN ztstar(i,j) = 0.5_wp * ( 255.0_wp + ztstar(i,j)) ENDIF IF(hsurf(i,j) > 2500.0_wp) THEN zt0s = MIN(zt0(i,j),298.0_wp) zalpha(i,j) = r_d * (zt0s - ztstar(i,j))/(hsurf(i,j)*g) IF(zt0s < ztstar(i,j)) zalpha(i,j) = 0.0_wp ELSEIF((hsurf(i,j) <= 2500.0_wp) & .AND.(hsurf(i,j) >= 2000.0_wp)) THEN zt0s = 0.002_wp * (2500.0_wp-hsurf(i,j) * zt0(i,j) & +(hsurf(i,j)-2000.0_wp)*MIN(zt0(i,j),298.0_wp)) zalpha(i,j) = r_d * (zt0s - ztstar(i,j))/(hsurf(i,j)*g) IF(zt0s < ztstar(i,j)) zalpha(i,j) = 0.0_wp ENDIF ENDDO ENDDO !$acc end parallel ENDIF IF (TRIM(ylistname) == 'FI') THEN !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend ! calculation of the soil temperature (ztstar) from the temperature ! of the lowest model level DO i=istartpar,iendpar ztstar(i,j) = t(i,j,ke,itl) + 0.0065_wp & * 0.5_wp*(hhl(i,j,ke)-hhl(i,j,ke+1)) zalpha(i,j) = 0.0065_wp*r_d/g zt0 (i,j) = ztstar(i,j) + 0.0065_wp * hsurf(i,j) ENDDO ENDDO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar IF (ztstar(i,j) <= 290.5_wp .AND. zt0(i,j) > 290.5_wp) THEN zalpha(i,j) = r_d*(290.5_wp - ztstar(i,j))/(hsurf(i,j)*g) ELSEIF (ztstar(i,j) > 290.5_wp .AND. zt0(i,j) > 290.5_wp) THEN ztstar(i,j) = 0.5_wp*(290.5_wp + ztstar(i,j)) zalpha(i,j) = 0.0_wp ELSEIF (ztstar(i,j) < 255.0_wp) THEN ztstar(i,j) = 0.5_wp*(255.0_wp + ztstar(i,j)) ENDIF ENDDO ENDDO !$acc end parallel ENDIF IF (ylistname(1:izlen) == 'T' ) THEN !$acc parallel !$acc loop gang vector collapse(2) private( zalnp ) DO j=jcstart,jcend DO i=istartpar,iendpar IF (zdelp(i,j) > 0.0_wp) THEN ! extrapolation of the model data if the required pressure level ! is below the lowest modellevel DO k=ke+1,ke+4 pexp(i,j,k) = ps(i,j,itl) & + (zdelp(i,j) + delpchk)/4.0_wp* REAL (k-ke, wp) zalnp = zalpha(i,j) * LOG(pexp(i,j,k)/ps(i,j,itl)) fexp(i,j,k) = ztstar(i,j) * & ( 1.0_wp + zalnp + 0.5_wp*zalnp**2 + 0.1667_wp*zalnp**3) ENDDO ENDIF ENDDO ENDDO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'FI' ) THEN !$acc parallel !$acc loop gang vector collapse(2) private( zpexp, zalnp ) DO j=jcstart,jcend DO i=istartpar,iendpar IF (zdelp(i,j) > 0.0_wp) THEN DO k=ke+1,ke+4 zpexp = ps(i,j,itl) & + (zdelp(i,j) + delpchk)/4.0_wp* REAL (k-ke, wp) zalnp = zalpha(i,j) * LOG(zpexp/ps(i,j,itl)) fexp(i,j,k) = hsurf(i,j) * g & -r_d*ztstar(i,j) * LOG(zpexp/ps(i,j,itl))* & (1.0_wp+zalnp & +0.5_wp*zalnp**2 & +0.1667_wp*zalnp**3) pexp(i,j,k) = LOG(zpexp) ENDDO ENDIF ENDDO ENDDO !$acc end parallel ELSE !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar IF (zdelp(i,j) > 0.0_wp) THEN DO k=ke+1,ke+4 pexp(i,j,k) = ps(i,j,itl) & + (zdelp(i,j) + delpchk)/4.0_wp* REAL (k-ke, wp) fexp(i,j,k) = fexp(i,j,ke) ENDDO ENDIF ENDDO ENDDO !$acc end parallel ENDIF SELECT CASE (zitype_vertint) CASE (1) ! Spline interpolation over (i,k)-slices ! -------------------------------------- CALL tautsp3D (pexp, fexp, kint, ie, je, istartpar, iendpar, & jcstart, jcend, ke+4, gamma, s_vec, break_vec, & coef_vec, nldim, ierr, lacc=.TRUE.) IF (ierr == 2) THEN yerrmsg = 'wrong input in tautsp3D' ierrstat = 1004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF IF (ierr /= 0) THEN yerrmsg = ' ERROR *** Error in tautsp3D *** ' ierrstat = 1005 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF CALL spline3D(break_vec, coef_vec, nldim, pfls, outblock%kepin, & istartpar, iendpar, jcstart, jcend, results, & ! outblock%yvarpl(nlist), lacc=.TRUE.) ylistname, lacc=.TRUE.) CASE (2) ! Linear Interpolation with respect to pressure: ! ---------------------------------------------- ! .. provide monotonically increasing dummy values for pexp(:,ke+1:ke+4) ! below the surface, because lininterp3D_xinter1D_vec() ! requires that all values of pexp are prescribed: !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar IF (zdelp(i,j) <= 0.0_wp) THEN DO k=ke+1,ke+4 pexp(i,j,k) = ps(i,j,itl) & + delpchk/4.0_wp* REAL (k-ke, wp) fexp(i,j,k) = fexp(i,j,ke) ENDDO ENDIF ENDDO END DO !$acc end parallel ierr = 0 CALL lininterp3D_xinter3D_vec(pexp, fexp, istartpar, iendpar, & jcstart, jcend, 1, ke+4, pfls, results, outblock%kepin, & ierr, lacc=.TRUE.) IF (ierr /= 0) THEN yerrmsg = ' ERROR *** Error in lininterp3D_xinter1D_vec *** ' ierrstat = 1006 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF CASE default yerrmsg = ' ERROR *** Wrong value for zitype_vertint *** ' ierrstat = 1007 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) END SELECT !.. UB: Correct interpolation artifacts: ! (MAY BE COMMENTED IN BY SPECIALIZED USERS, BUT NOT OPERATIONNALY AT DWD!) !!$ IF (TRIM(ylistname) == 'RELHUM') THEN !!$ results(istartpar:iendpar,j,:) = MAX (0.0_wp, MIN(100.0_wp,results(istartpar:iendpar,j,:))) !!$ ELSEIF (TRIM(ylistname) == 'QC') THEN !!$ results(istartpar:iendpar,j,:) = MAX (0.0_wp, results(istartpar:iendpar,j,:) ) !!$ END IF #ifndef _OPENACC END DO !loop over jb #endif ! In case of radar reflectivity, transform back to log space after interpolation: IF (ylistname(1:izlen) == 'DBZ') THEN !$acc parallel !$acc loop gang vector collapse(3) DO k=1,outblock%kepin DO j=jstartpar,jendpar DO i=istartpar,iendpar IF (results(i,j,k) >= 1.0E-9_wp) THEN results(i,j,k) = & 10.0_wp * LOG10(results(i,j,k)) ELSE results(i,j,k) = -99.99_wp END IF END DO END DO END DO !$acc end parallel END IF !.. UB: Set data below the surface to missing values: ! (MAY BE COMMENTED IN BY SPECIALIZED USERS, BUT NOT OPERATIONNALY AT DWD!) !!$ SELECT CASE (ylistname(1:izlen)) !!$ CASE ('DBZ') !!$ DO i=istartpar,iendpar !!$ DO j=jstartpar,jendpar !!$ DO k=1,outblock%kepin !!$ IF (outblock%plev(k) > ps(i,j,itl)) results(i,j,k) = -99.99 !!$ ENDDO !!$ ENDDO !!$ ENDDO !!$ CASE default !!$ DO i=istartpar,iendpar !!$ DO j=jstartpar,jendpar !!$ DO k=1,outblock%kepin !!$ IF (outblock%plev(k) > ps(i,j,itl)) results(i,j,k) = 0.0_wp !!$ ENDDO !!$ ENDDO !!$ ENDDO !!$ END SELECT !$acc end data !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE p_int !============================================================================== !+ Module procedure in src_output for the z-interpolation !------------------------------------------------------------------------------ SUBROUTINE z_int (outblock, i1,i2,i3, ylistname, idebug, results) !------------------------------------------------------------------------------ ! ! Description: ! This subroutine interpolates a number of 3-d variables, given by namelist- ! input to this routine, from model layers to fixed-height levels (z-levles) ! ! Method: ! Colum wise interpolation with tension splines. ! For the interpolation of FI and QV the logarithm of the pressure is ! used. ! !------------------------------------------------------------------------------ ! Subroutine / Function arguments ! Scalar arguments with intent(in): TYPE(pp_nl), INTENT(IN) :: & outblock ! pointer to the namelist group INTEGER , INTENT(IN) :: & i1,i2,i3, & ! location of the variable to be processed in the LM ! variable table idebug ! for debug output CHARACTER (LEN=*) :: ylistname ! Array arguments with intent(out): REAL (KIND=wp) , INTENT(OUT):: & results(ie,je,outblock%kezin) !------------------------------------------------------------------------------ ! Local parameters REAL(KIND=wp), PARAMETER :: gamma = 5.5_wp ! tension factor INTEGER :: i, j, k INTEGER :: jcstart, jcend !compute start end !indices in j direction #ifndef _OPENACC INTEGER :: jb ! index used for block optimization on CPU #endif INTEGER :: ierrstat, ierr, izlen INTEGER :: nldim(ie,je), kint(ie,je) CHARACTER (LEN=25) :: yroutine CHARACTER (LEN=80) :: yerrmsg CHARACTER (LEN=clen) :: yzname ! Local arrays: REAL(KIND=wp) :: fmfl(ie,je,ke+1), & zmfl(ie,je,ke+1) REAL(KIND=wp) :: fexp(ie,je,ke+4), & zexp(ie,je,ke+4) ! Output from tautsp3D REAL(KIND=wp) :: s_vec (ie,je,(ke+4)*6), & break_vec(ie,je,(ke+4)*3), & coef_vec (ie,je,4,(ke+4)*3) ! Output from spline ! for interpolation to levels above ground, zfls needs the i-dimension REAL(KIND=wp) :: zfls (ie,je,outblock%kezin) ! Switch to choose between vertical interpolation methods: ! Local value; there is a global namelist parameter itype_vertint ! in each namelist of group GRIBOUT. INTEGER :: zitype_vertint ! ! Switch to choose if values of, U, V, W, and T are extrapolated ! to the surface based on no-slip- and skin-condition ! or if a constant extrapolation is done. ! The former is not so good for cubic spline interpolation ! because of oszillations with unwanted results, so we ! allow it only for linear interpolation. LOGICAL :: zlsurfextrapol_noslip ! Pointer needed for OpenACC port of derived types REAL(kind=wp), DIMENSION(:,:,:), POINTER :: zvarp3_ptr REAL(kind=wp), DIMENSION(:,:,:,:), POINTER :: zvarp4_ptr REAL(KIND=wp) :: zmfl_max INTEGER :: itl_loc !------------------------------------------------------------------------------ ! Section 1: general and grib-io preparations !------------------------------------------------------------------------------ yroutine = 'z_int' izlen = LEN_TRIM(ylistname) ! The default value is taken from the namelist value, ! which may be "hard" changed for single fields below ! (e.g., if you would not like to have splineinterpolation for fiels like QC ...) zitype_vertint = outblock%itype_vertint ! Allow no-slip- and skin-condition-extrapolation to the ! surface only for linear interpolation: IF (zitype_vertint == 2) THEN zlsurfextrapol_noslip = .TRUE. ELSE zlsurfextrapol_noslip = .FALSE. END IF !------------------------------------------------------------------------------ ! Section 1: Set variable that has to be interpolated !------------------------------------------------------------------------------ ! calculation of u and v on masspoint ! ----------------------------------- itl_loc = itl #ifdef STATIC_FIELDS IF ( var(i1,i2,i3)%lsm == 't') itl_loc=trcr_itl #endif zvarp3_ptr => var(i1,i2,i3)%p3 zvarp4_ptr => var(i1,i2,i3)%p4 !$acc data present( zvarp4_ptr, zvarp3_ptr, hhl, hsurf, p0, pp, ps, t, t_g, & !$acc zqrs_itl, zrho_itl, p_anai, qv, qi ) & !$acc pcreate( fmfl, zexp, fexp, kint, zmfl, nldim, zfls, s_vec, & !$acc break_vec, coef_vec ) IF (ylistname(1:izlen) == 'U' ) THEN !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=2,ie fmfl(i,j,k) = 0.5_wp * (zvarp4_ptr(i,j,k,itl) & + zvarp4_ptr(i-1,j,k,itl)) END DO END DO END DO !$acc end parallel !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO k=1,ke DO j=1,je fmfl(1,j,k) = fmfl(2,j,k) END DO END DO !$acc end parallel IF (lnosurffluxes_m .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke ) END DO END DO !$acc end parallel ELSE ! For interpolation: Surface velocity = 0 !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = 0.0_wp END DO END DO !$acc end parallel END IF ELSEIF (ylistname(1:izlen) == 'V' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=2,je DO i=1,ie fmfl(i,j,k) = 0.5_wp * (zvarp4_ptr(i,j,k,itl) & + zvarp4_ptr(i,j-1,k,itl)) END DO END DO END DO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO k=1,ke DO i=1,ie fmfl(i,1,k) = fmfl(i,2,k) END DO END DO !$acc end parallel IF (lnosurffluxes_m .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke ) END DO END DO !$acc end parallel ELSE ! For interpolation: Surface velocity = 0 !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = 0.0_wp END DO END DO !$acc end parallel END IF ELSEIF (yzname(1:izlen) == 'SP_AV' ) THEN !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=2,je DO i=1,ie fmfl(i,j,k) = var(i1,i2,i3)%p3(i,j,k) END DO END DO END DO !$acc end parallel IF (lnosurffluxes_m .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke ) END DO END DO !$acc end parallel ELSE ! For interpolation: Surface velocity = 0 !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = 0.0_wp END DO END DO !$acc end parallel END IF ELSEIF (ylistname(1:izlen) == 'P' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = p0(i,j,k) + pp(i,j,k,itl) END DO END DO END DO !$acc end parallel ! For interpolation: Surface pressure at the ground! !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = ps(i,j,itl) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'W' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl) END DO END DO END DO !$acc end parallel IF (lnosurffluxes_m .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSE ! For interpolation: Surface vertical velocity = 0 !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = 0.0_wp END DO END DO !$acc end parallel END IF ELSEIF (ylistname(1:izlen) == 'T' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl) END DO END DO END DO !$acc end parallel IF (lnosurffluxes_h .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSE ! For interpolation: Surface temperature = interfacial temperature !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = t_g(i,j,0,itl) END DO END DO !$acc end parallel END IF ELSEIF (ylistname(1:izlen) == 'TKVM' .OR. ylistname(1:izlen) == 'TKVH') THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=2,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,0) END DO END DO END DO !$acc end parallel !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,1) = fmfl(i,j,2) END DO END DO !$acc end parallel !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'TKE' ) THEN SELECT CASE( itype_turb ) CASE( 5:8 ) !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = var(i1,i2,i3)%p5(i,j,k,0,itl) END DO END DO END DO !$acc end parallel CASE DEFAULT !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = 0.5_wp * (var(i1,i2,i3)%p5(i,j,k,0,itl))**2 END DO END DO END DO !$acc end parallel END SELECT !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'QRS') THEN IF (outblock%loutput_q_densities) THEN ! output as densities: !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSE ! output as mass specific: !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel END IF !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'Q_SEDIM') THEN IF (ASSOCIATED(qi)) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) - qi(i,j,k) END DO END DO END DO !$acc end parallel ELSE !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zqrs_itl(i,j,k) END DO END DO END DO !$acc end parallel ENDIF IF (outblock%loutput_q_densities) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = fmfl(i,j,k) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel END IF !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'RELHUM') THEN CALL calrelhum(fmfl, t(:,:,:,itl), pp(:,:,:,itl), p0(:,:,:), & qv(:,:,:),ie, je, ke, b1, b2w, b3, b4w, rdv, o_m_rdv, & lacc=.TRUE.) !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'OMEGA') THEN CALL calomega (fmfl, pp(:,:,:,nnew), pp(:,:,:,itl), pptens(:,:,:), & w(:,:,:,itl), rho0(:,:,:), ie, je, ke, dt, g, & lacc=.TRUE.) !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'FI_ANAI' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = p_anai(i,j,k) / zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSEIF (ylistname(1:izlen) == 'QC' .OR. ylistname(1:izlen) == 'NCCLOUD' .OR. & ylistname(1:izlen) == 'QR' .OR. ylistname(1:izlen) == 'NCRAIN' .OR. & ylistname(1:izlen) == 'QI' .OR. ylistname(1:izlen) == 'NCICE' .OR. & ylistname(1:izlen) == 'QS' .OR. ylistname(1:izlen) == 'NCSNOW' .OR. & ylistname(1:izlen) == 'QG' .OR. ylistname(1:izlen) == 'NCGRAUPEL' .OR. & ylistname(1:izlen) == 'QH' .OR. ylistname(1:izlen) == 'NCHAIL') THEN ! Output of cloud microphysics variables either as densities or mass specific: IF (outblock%loutput_q_densities) THEN ! output as densities: !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl_loc) * zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel ELSE ! output as mass specific: !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl_loc) END DO END DO END DO !$acc end parallel END IF !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel #ifdef RADARFWO ELSEIF (ylistname(1:izlen) == 'DBZ') THEN #ifdef _OPENACC CALL model_abort(my_cart_id, ierrstat, "Error: EMVORADO not ported to GPU", yroutine) #endif CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), zh_radar_wp = fmfl(:,:,1:ke) ) !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ! Reflectivity is now delivered in linear space by calc_dbz_vec_modelgrid(). ! This is where interpolation should be done, not in logarithmic space. ! (as alternative, interpolation in the space of rain rate -- Z^0.6666 --- ! would also be desireable): !UB ELSEIF (ylistname(1:izlen) == 'VTERM') THEN ELSEIF (ylistname(1:izlen) == 'DUMMY_1') THEN IF (luse_radarfwo) THEN CALL calc_fallspeed_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, lwdbz=lweightdbz, & ldebug=ldebug_io, vt_radar_wp=fmfl(:,:,1:ke)) ELSE CALL calc_fallspeed_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, lwdbz=.TRUE., & ldebug=ldebug_io, vt_radar_wp=fmfl(:,:,1:ke)) END IF !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel !UB ELSEIF (ylistname(1:izlen) == 'EXT_DBZ') THEN ELSEIF (ylistname(1:izlen) == 'DUMMY_2') THEN CALL calc_dbz_vec_modelgrid (itl_dyn=itl, itl_qx=itl, idom=1, namlist_in=outblock%dbz, l_use_neigh_tmax_melt=.TRUE., & ldebug=ldebug_io, ydir_lookup_read=TRIM(ydir_mielookup_read), & ydir_lookup_write=TRIM(ydir_mielookup_write), ah_radar_wp = fmfl(:,:,1:ke) ) !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke+1 DO j=1,je DO i=1,ie fmfl(i,j,k) = 20.0e3_wp / LOG(10.0_wp) * fmfl(i,j,k) END DO END DO END DO !$acc end parallel #else ELSEIF (ylistname(1:izlen) == 'DBZ') THEN IF (itype_gscp == 3) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, idebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & z_radar = fmfl, lacc=.TRUE. ) ELSEIF (itype_gscp == 4) THEN !$acc parallel default(present) !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel CALL radar_lm_ray (ie,je,ke, pi, rho_w, rho_ice, K_w, K_ice, t0_melt, & klv850, my_cart_id, itype_gscp, idebug, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), zqi_itl(:,:,:), zqs_itl(:,:,:), & q_grau = zqg_itl(:,:,:), z_radar = fmfl, lacc=.TRUE. ) #ifdef TWOMOM_SB ELSEIF (itype_gscp >= 100) THEN DO k=1,ke DO j=1,je DO i=1,ie zqc_itl(i,j,k) = qc(i,j,k)*zrho_itl(i,j,k) zqr_itl(i,j,k) = qr(i,j,k)*zrho_itl(i,j,k) zqi_itl(i,j,k) = qi(i,j,k)*zrho_itl(i,j,k) zqs_itl(i,j,k) = qs(i,j,k)*zrho_itl(i,j,k) zqg_itl(i,j,k) = qg(i,j,k)*zrho_itl(i,j,k) zqh_itl(i,j,k) = qh(i,j,k)*zrho_itl(i,j,k) zqnc_itl(i,j,k) = qnc(i,j,k)*zrho_itl(i,j,k) zqnr_itl(i,j,k) = qnr(i,j,k)*zrho_itl(i,j,k) zqni_itl(i,j,k) = qni(i,j,k)*zrho_itl(i,j,k) zqns_itl(i,j,k) = qns(i,j,k)*zrho_itl(i,j,k) zqng_itl(i,j,k) = qng(i,j,k)*zrho_itl(i,j,k) zqnh_itl(i,j,k) = qnh(i,j,k)*zrho_itl(i,j,k) END DO END DO END DO CALL radar_sb_ray (ie, je, ke, pi, & klv850, my_cart_id, t(:,:,:,itl), & zqc_itl(:,:,:), zqr_itl(:,:,:), & zqi_itl(:,:,:), zqs_itl(:,:,:), & zqg_itl(:,:,:), zqh_itl(:,:,:), & zqnc_itl(:,:,:), zqnr_itl(:,:,:), & zqni_itl(:,:,:), zqns_itl(:,:,:), & zqng_itl(:,:,:), zqnh_itl(:,:,:), & z_radar = fmfl(:,:,1:ke), lacc=.TRUE. ) #endif ENDIF #endif !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ! Reflectivity is now delivered in linear space by radar_XX_ray(). ! This is where interpolation should be done, not in logarithmic space. ! (as alternative, interpolation in the space of rain rate -- Z^0.6666 --- ! would also be desireable): ELSEIF ( ylistname(1:izlen) == 'PT' ) THEN ! potential temperature !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = t(i,j,k,itl) * & (p0ref/(p0(i,j,k)+pp(i,j,k,itl)))**(r_d/cp_d) END DO END DO END DO !$acc end parallel IF (lnosurffluxes_h .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSE ! For interpolation: Surface temperature = interfacial temperature !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = t_g(i,j,0,itl) * & (p0ref/ps(i,j,itl))**(r_d/cp_d) END DO END DO !$acc end parallel END IF ELSEIF ( ylistname(1:izlen) == 'THETA_V' ) THEN ! virtual potential temperature !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = t(i,j,k,itl) * & (p0ref/(p0(i,j,k)+pp(i,j,k,itl)))**(r_d/cp_d) * & (1.0_wp + rvd_m_o * qv(i,j,k)) END DO END DO END DO !$acc end parallel IF (lnosurffluxes_h .OR. .NOT.zlsurfextrapol_noslip) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ! For interpolation: Surface temperature = interfacial temperature !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = t_g(i,j,0,itl) * & (p0ref/ps(i,j,itl))**(r_d/cp_d) * & (1.0_wp + rvd_m_o * qv(i,j,ke)) END DO END DO !$acc end parallel END IF ELSEIF ( ylistname(1:izlen) == 'DEN' ) THEN !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zrho_itl(i,j,k) END DO END DO END DO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke1) = fmfl(i,j,ke) END DO END DO !$acc end parallel ELSE IF (var(i1,i2,i3)%idimvert < ke) THEN ! this variable cannot be interpolated to z levels yerrmsg = 'Variable cannot be interpolated to z levels: ' WRITE (yerrmsg(48:63), '(A16)') TRIM(var(i1,i2,i3)%name) ierrstat = 2004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ELSE SELECT CASE( var(i1,i2,i3)%rank ) CASE(4) IF (var(i1,i2,i3)%ltiles) THEN ! this is a 3D variable + tiles ! this is NOT a 2D variable with tiles and time dimension, ! because this would have idimvert < ke !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,0) END DO END DO END DO !$acc end parallel ELSE ! this is a 3D variable + time dimension !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp4_ptr(i,j,k,itl_loc) END DO END DO END DO !$acc end parallel ENDIF CASE(3) ! this is a 3D variable (no tiles, no time: because then idimvert < ke) !$acc parallel !$acc loop gang vector collapse(3) DO k=1,ke DO j=1,je DO i=1,ie fmfl(i,j,k) = zvarp3_ptr(i,j,k) END DO END DO END DO !$acc end parallel END SELECT ENDIF ! idimvert < ke !CDIR COLLAPSE !$acc parallel !$acc loop gang vector collapse(2) DO j=1,je DO i=1,ie fmfl(i,j,ke+1) = fmfl(i,j,ke ) END DO END DO !$acc end parallel ENDIF !------------------------------------------------------------------------------ ! Section 2: Interpolation !------------------------------------------------------------------------------ ! Hardwired choice of linear interpolation for hydrometeors and DBZ to ! prevent spurious overshoots: IF ( ylistname(1:izlen) == 'QC' .OR. ylistname(1:izlen) == 'QR' .OR. & ylistname(1:izlen) == 'QI' .OR. ylistname(1:izlen) == 'QS' .OR. & ylistname(1:izlen) == 'QG' .OR. ylistname(1:izlen) == 'QH' .OR. & ylistname(1:3) == 'DBZ' .OR. & !UB ylistname(1:izlen) == 'EXT_DBZ' .OR. & ylistname(1:izlen) == 'DUMMY_2' .OR. & !UB ylistname(1:izlen) == 'VTERM' ) THEN ylistname(1:izlen) == 'DUMMY_1' ) THEN zitype_vertint = 2 END IF #ifdef TWOMOM_SB IF ( ylistname(1:izlen) == 'NCCLOUD' .OR. ylistname(1:izlen) == 'NCRAIN' .OR. & ylistname(1:izlen) == 'NCICE' .OR. ylistname(1:izlen) == 'NCSNOW' .OR. & ylistname(1:izlen) == 'NCGRAUPEL' .OR. ylistname(1:izlen) == 'NCHAIL' ) THEN zitype_vertint = 2 END IF #endif ! slicewise interpolation ! ----------------------- !Optimization : On CPU block loop going over all j points ! On GPU no blocking #ifndef _OPENACC !CPU DO jb=jstartpar,jendpar jcstart=jb jcend=jb #else !GPU jcstart=jstartpar jcend=jendpar #endif ! Set the height of the model levels (zmfl) SELECT CASE(var(i1,i2,i3)%levtyp) CASE(110) !$acc parallel !$acc loop gang vector collapse(3) DO k = 1, ke DO j=jcstart,jcend DO i = 1, ie zmfl(i,j,k) = 0.5_wp * ( hhl(i,j,k) + hhl(i,j,k+1) ) ENDDO ENDDO ENDDO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i = 1, ie zmfl(i,j,ke+1) = hsurf(i,j) ENDDO ENDDO !$acc end parallel CASE(109) !$acc parallel !$acc loop gang vector collapse(3) DO k = 1, ke+1 DO j=jcstart,jcend DO i = 1, ie zmfl(i,j,k) = hhl(i,j,k) ENDDO ENDDO ENDDO !$acc end parallel CASE DEFAULT yerrmsg = 'wrong leveltyp of input field' ierrstat = 2004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) END SELECT ! Set the height of the z-levels to interpolate to (zfls). ! (done on host: zlev is not on GPU??) IF (outblock%lzint_above_ground) THEN ! output to height levels above ground !$acc parallel copy( outblock ) copyin( outblock%zlev(:) ) !$acc loop gang vector collapse(3) DO k = 1, outblock%kezin DO j=jcstart,jcend DO i = 1, ie zfls(i,j,k) = hhl(i,j,ke+1) + outblock%zlev(k) ENDDO ENDDO ENDDO !$acc end parallel ELSE ! output to altitude above mean sea level !$acc parallel copy( outblock ) copyin( outblock%zlev(:) ) !$acc loop gang vector collapse(3) DO k = 1, outblock%kezin DO j=jcstart,jcend DO i = 1, ie zfls(i,j,k) = outblock%zlev(k) ENDDO ENDDO ENDDO !$acc end parallel ENDIF zmfl_max = -huge(1.0_wp) !$acc parallel !$acc loop gang vector collapse(2) reduction (max:zmfl_max) DO j=jcstart,jcend DO i=1,ie IF (zmfl(i,j,1) > zmfl_max) THEN zmfl_max = zmfl(i,j,1) ENDIF ENDDO ENDDO !$acc end parallel ! Check if a zlevel for interpolation is above the model top height: IF ( MAXVAL(outblock%zlev(1:outblock%kezin)) >= zmfl_max ) THEN yerrmsg = 'zlev for interpolation above model top!' ierrstat = 1004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) END IF ! To handle cases where the lowest z-level is below the orography, an ! additional data point at z = - 100mf will be created, assuming a ! constant profile. ! The interpolated variable value will be set to undefined. ! vertical interpolation colum wise ! --------------------------------- !$acc parallel !$acc loop gang vector collapse(2) DO j=jcstart,jcend DO i=istartpar,iendpar ! copy slice variable to colum variable (in reverse order, because ! data points must strictly increase in tautsp3D) and add an extra ! data/function point in any case kint (i,j) = ke + 2 zexp (i,j,1) = MIN (-100.0_wp, zmfl(i,j,ke+1) - 20.0_wp) fexp (i,j,1) = fmfl(i,j,ke+1) nldim(i,j) = (ke+4)*3 ENDDO ENDDO !$acc end parallel !$acc parallel !$acc loop gang vector collapse(3) DO k = 1, ke1 DO j=jcstart,jcend DO i=istartpar,iendpar zexp(i,j,k+1) = zmfl(i,j,ke+2-k) fexp(i,j,k+1) = fmfl(i,j,ke+2-k) ENDDO ENDDO ENDDO !$acc end parallel ! Spline interpolation over total domain or slicewise ! --------------------------------------------------- SELECT CASE (zitype_vertint) CASE (1) ! Interpolation by cubic TauT-Splines (Tension Splines): ! ------------------------------------------------------ CALL tautsp3D (zexp, fexp, kint, ie, je, istartpar, iendpar, & jcstart, jcend, ke+4, gamma, s_vec, break_vec, & coef_vec, nldim, ierr, lacc=.TRUE.) IF (ierr == 2) THEN yerrmsg = 'wrong input in tautsp3D' ierrstat = 1004 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF IF (ierr /= 0) THEN yerrmsg = ' ERROR *** Error in tautsp3D *** ' ierrstat = 1005 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF CALL spline3D(break_vec, coef_vec, nldim, zfls, outblock%kezin, & istartpar, iendpar, jcstart, jcend, results, & ! outblock%yvarzl(nlist), lacc=.TRUE.) ylistname, lacc=.TRUE.) CASE (2) ! Linear Interpolation with respect to height: ! -------------------------------------------- ierr = 0 CALL lininterp3D_xinter3D_vec(zexp, fexp, istartpar, iendpar, & jcstart, jcend, 1, ke+2, zfls, results, & outblock%kezin, ierr, lacc=.TRUE.) IF (ierr /= 0) THEN yerrmsg = ' ERROR *** Error in lininterp3D_xinter1D_vec *** ' ierrstat = 1006 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) ENDIF CASE default yerrmsg = ' ERROR *** Wrong value for zitype_vertint *** ' ierrstat = 1007 CALL model_abort (my_cart_id, ierrstat, yerrmsg, yroutine) END SELECT !.. UB: Correct interpolation artifacts: ! (MAY BE COMMENTED IN BY SPECIALIZED USERS, BUT NOT OPERATIONNALY AT DWD!) !!$ IF (TRIM(ylistname) == 'RELHUM') THEN !!$ results(:,j,:) = MAX (0.0_wp, MIN(100.0_wp,results(:,j,:))) !!$ ELSEIF (TRIM(ylistname) == 'QC') THEN !!$ results(:,j,:) = MAX (0.0_wp, results(:,j,:) ) !!$ END IF #ifndef _OPENACC END DO !loop over jb #endif ! In case of radar reflectivity, transform back to log space after interpolation: IF (ylistname(1:izlen) == 'DBZ') THEN !$acc parallel !$acc loop gang vector collapse(3) DO k=1,outblock%kezin DO j=jstartpar,jendpar DO i=istartpar,iendpar IF (results(i,j,k) >= 1.0E-9_wp) THEN results(i,j,k) = & 10.0_wp * LOG10(results(i,j,k)) ELSE results(i,j,k) = -99.99_wp END IF END DO END DO END DO !$acc end parallel END IF !.. UB: Set data below the surface to missing values: ! (MAY BE COMMENTED IN BY SPECIALIZED USERS, BUT NOT OPERATIONNALY AT DWD!) !!$ SELECT CASE (ylistname(1:izlen)) !!$ CASE ('DBZ') !!$ DO i=istartpar,iendpar !!$ DO j=jstartpar,jendpar !!$ DO k=1,outblock%kezin !!$ IF (outblock%zlev(k) < hsurf(i,j)) results(i,j,k) = -99.99 !!$ ENDDO !!$ ENDDO !!$ ENDDO !!$ CASE default !!$ DO i=istartpar,iendpar !!$ DO j=jstartpar,jendpar !!$ DO k=1,outblock%kezin !!$ IF (outblock%zlev(k) < hsurf(i,j)) results(i,j,k) = 0.0_wp !!$ ENDDO !!$ ENDDO !!$ ENDDO !!$ END SELECT !$acc end data !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE z_int !============================================================================== !+ calculates the function values for given coefficients !------------------------------------------------------------------------------ SUBROUTINE spline (break, coef, nldim, sptau, spgtau, ng) !------------------------------------------------------------------------------ ! ! Description: ! spline calculates the values of the interpolation function for given ! interpolation coefficients and arguments ! ! Method: ! Spline interpolation. ! !------------------------------------------------------------------------------ ! Subroutine / Function arguments ! Scalar arguments with intent(in): INTEGER, INTENT(IN) :: & nldim, ng ! Dimensions of the variables ! ! Array arguments with intent(in): REAL (KIND=wp), INTENT(IN) :: & break(nldim), & ! arguments for which the function has to be calculated coef(4,nldim), & ! coefficients of the interpolation function sptau(ng) ! ! ! Array arguments with intent(out): REAL (KIND=wp), INTENT(OUT) :: & spgtau(ng) !------------------------------------------------------------------------------ ! Local scalars: INTEGER :: i, j REAL (KIND=wp) :: dx, prod ! !- End of header !============================================================================== ! Calculate the product (sptau(i)-break(j)) * (sptau(i)-break(j+1)) ! and look for the interval where sptau is DO i = 1, ng DO j = 1, nldim-1 prod = (sptau(i) - break(j)) * (sptau(i) - break(j+1)) ! calculate the splines IF( prod <= 0.0_wp ) THEN dx = sptau(i) - break(j) spgtau(i) = coef(1,j) + dx * (coef(2,j) + dx*0.5_wp*(coef(3,j) & + dx/3.0_wp* coef(4,j))) EXIT ENDIF ENDDO ENDDO !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE spline !============================================================================== !option! -pvctl _on_adb SUBROUTINE spline3D (break_vec, coef_vec, nldim, sptau, ng, & isc, iec, jsc, jec, results, yname, lacc ) !------------------------------------------------------------------------------ ! ! Description: ! spline calculates the values of the interpolation function for given ! interpolation coefficients and arguments ! ! Method: ! Spline interpolation. ! !------------------------------------------------------------------------------ ! Subroutine / Function arguments ! Scalar arguments with intent(in): INTEGER , INTENT(IN) :: & ng, & ! Dimensions of variables and line to be processed isc, iec, jsc, jec ! start, end compute index in the 1st and 2nd dimension INTEGER , INTENT(IN) :: & nldim(ie,je) ! ! Array arguments with intent(in): REAL (KIND=wp), INTENT(IN) :: & break_vec(ie,je,ke*3), & ! arguments for which the function is calculated coef_vec (ie,je,4,ke*3),& ! coefficients of the interpolation function sptau(ie,je,ng) ! every grid point can have different heights CHARACTER (LEN=clen), INTENT(IN) :: yname ! Array arguments with intent(out): REAL(KIND=wp), INTENT(OUT) :: results(ie,je,ng) LOGICAL, OPTIONAL, INTENT(IN) :: & lacc ! flag to run on GPU !------------------------------------------------------------------------------ ! Local scalars: INTEGER :: i, j, k, iz REAL (KIND=wp) :: dx LOGICAL :: lfind, lzacc ! !- End of header !============================================================================== IF (PRESENT(lacc)) THEN lzacc = lacc ELSE lzacc = .FALSE. ENDIF !$acc parallel if (lzacc) default(present) !$acc loop gang vector private(lfind,dx) collapse(3) DO j = jsc, jec DO i = isc, iec DO iz = 1,ng lfind=.false. !$acc loop seq DO k=1,nldim(i,j)-1 IF (.NOT. lfind .AND. (sptau(i,j,iz)<=break_vec(i,j,k+1))) THEN lfind=.true. dx = sptau(i,j,iz) - break_vec(i,j,k) results(i,j,iz) = coef_vec(i,j,1,k) + dx *(coef_vec(i,j,2,k) + & dx*0.5_wp*(coef_vec(i,j,3,k) + dx/3.0_wp * coef_vec(i,j,4,k))) ENDIF END DO ENDDO ENDDO END DO !$acc end parallel SELECT CASE (yname) CASE ('RELHUM ') !$acc parallel if (lzacc) default(present) !$acc loop gang vector collapse(3) DO iz = 1, ng DO j = jsc, jec DO i = isc, iec results(i,j,iz) = MAX (0.0_wp, MIN(100.0_wp,results(i,j,iz))) ENDDO ENDDO ENDDO !$acc end parallel CASE ('QV ','QC ','QI ', & 'QR ','QS ','QG ', & 'QH ','NCCLOUD ','NCICE ', & 'NCRAIN ','NCSNOW ','NCGRAUPEL ','NCHAIL ' ) !$acc parallel if (lzacc) default(present) !$acc loop gang vector collapse(3) DO iz = 1,ng DO j = jsc, jec DO i = isc, iec results(i,j,iz) = MAX (0.0_wp, results(i,j,iz) ) ENDDO ENDDO ENDDO !$acc end parallel END SELECT !------------------------------------------------------------------------------ ! End of the subroutine !------------------------------------------------------------------------------ END SUBROUTINE spline3D !============================================================================== !============================================================================== !+ Module procedure in src_output for the horizontal smoothing !------------------------------------------------------------------------------ SUBROUTINE smooth_pmsl ( pmsl, hsurf, ie, je ) !------------------------------------------------------------------------------ ! special smoothing of pmsl in mountainous terrain !------------------------------------------------------------------------------ ! Parameter list: INTEGER , INTENT (IN) :: ie, je REAL (KIND=wp), INTENT (IN) :: hsurf(ie,je) REAL (KIND=irealgrib), INTENT (INOUT) :: pmsl(ie,je) ! Local Variables REAL (KIND=wp) :: zp, hsurf_max, wgt, pmsl_sm(ie,je) INTEGER :: i, j, ii, jj, n, nmean !------------------------------------------------------------------------------ ! Begin subroutine smooth_pmsl PRINT *,' smoothing pmsl over mountainous terrain ' pmsl_sm(:,:) = REAL (pmsl(:,:), wp) hsurf_max = 750.0_wp DO n = 1,2 DO j = 1, je DO i = 1, ie IF (hsurf(i,j) >= hsurf_max) THEN IF (hsurf(i,j) >= 1000.0_wp) THEN nmean = 10 ELSE nmean = 5 ENDIF pmsl_sm(i,j) = 0.0_wp zp = 0.0_wp DO jj = j-nmean,j+nmean DO ii = i-nmean,i+nmean IF ( (ii >= 1) .AND. (ii <= ie) .AND. & (jj >= 1) .AND. (jj <= je) ) THEN IF (hsurf(ii,jj) < hsurf_max) THEN wgt = 2.0_wp ELSE wgt = 1.0_wp ENDIF pmsl_sm(i,j) = pmsl_sm(i,j) + wgt * REAL (pmsl(ii,jj), wp) zp = zp + wgt ENDIF ENDDO ENDDO pmsl_sm(i,j) = pmsl_sm(i,j) / zp ENDIF ENDDO ENDDO pmsl(:,:) = REAL (pmsl_sm(:,:), irealgrib) ENDDO END SUBROUTINE smooth_pmsl !============================================================================== !============================================================================== !+ Module procedure in src_output for the horizontal smoothing !------------------------------------------------------------------------------ SUBROUTINE smooth_geopot ( geopot, hsurf, ie, je ) !------------------------------------------------------------------------------ ! special smoothing of geopot in mountainous terrain !------------------------------------------------------------------------------ ! Parameter list: INTEGER , INTENT (IN) :: ie, je REAL (KIND=wp), INTENT (IN) :: hsurf(ie,je) REAL (KIND=irealgrib), INTENT (INOUT) :: geopot(ie,je) ! Local Variables REAL (KIND=wp) :: zp, wgt, geopot_diff, & geopot_sm(ie,je) INTEGER :: i, j, ii, jj, n, nmean !------------------------------------------------------------------------------ ! Begin subroutine smooth_geopot PRINT*,' smoothing of geopotential height over mountainous terrain ' geopot_sm(:,:) = REAL (geopot(:,:), wp) DO n = 1,2 DO j = 1,je DO i = 1,ie geopot_diff = g * hsurf(i,j) - REAL(geopot(i,j), wp) IF (geopot_diff > 1000.0_wp) THEN nmean = 10 ELSE nmean = 5 ENDIF geopot_sm(i,j) = 0.0_wp zp = 0.0_wp DO jj = j-nmean,j+nmean DO ii = i-nmean,i+nmean IF ( (ii >= 1) .AND. (ii <= ie) .AND. & (jj >= 1) .AND. (jj <= je) ) THEN geopot_diff = g * hsurf(ii,jj) - REAL(geopot(ii,jj), wp) wgt = 1.0_wp geopot_sm(i,j) = geopot_sm(i,j) + wgt*REAL(geopot(ii,jj), wp) zp = zp + wgt ENDIF ENDDO ENDDO geopot_sm(i,j) = geopot_sm(i,j) / zp ENDDO ENDDO geopot(:,:) = REAL (geopot_sm(:,:), irealgrib) ENDDO END SUBROUTINE smooth_geopot !============================================================================== !============================================================================== SUBROUTINE calc_sdi( sdi_1, sdi_2, lacc ) !------------------------------------------------------------------------------ ! ! Description: ! calculation of the 2 supercell detection indices (SDI) ! ! Method: ! defined in: ! Wicker L, J. Kain, S. Weiss and D. Bright, A Brief Description of the ! Supercell Detection Index, (available from ! http://www.spc.noaa.gov/exper/Spring_2005/SDI-docs.pdf) ! !------------------------------------------------------------------------------ REAL (KIND=wp), DIMENSION(1:ie,1:je), INTENT(OUT) :: sdi_1, sdi_2 INTEGER :: k_center INTEGER :: d_idx_x, d_idx_y, d_idx_z INTEGER :: i, j, k REAL (KIND=wp) :: dx, dx_aequ, dy REAL (KIND=wp), ALLOCATABLE, DIMENSION(:,:) :: & w_mean, & ! mean over box in 'height' k_center w2_mean, & ! mean over box in 'height' k_center zeta_mean, & ! mean over box in 'height' k_center zeta2_mean, & ! mean over box in 'height' k_center helic_mean ! mean over box in 'height' k_center REAL (KIND=wp), ALLOCATABLE, DIMENSION(:,:,:) :: & zeta, & ! vorticity w_s ! vertical velocity at scalar position LOGICAL, OPTIONAL, INTENT(IN) :: & lacc ! flag for running on gpu CHARACTER (LEN=80) :: yzerrmsg INTEGER :: izerror INTEGER :: kzdims(24) REAL (KIND=wp) :: helic_w_corr ! Correlation coefficient REAL (KIND=wp) :: zeta_vert_mean(ie,je) REAL (KIND=wp) :: w_crit_SDI2 (ie,je) ! Criterion, if SDI2 = 0 or not REAL (KIND=wp) :: EPS = 1.0E-20_wp LOGICAL :: lzacc !------------------------------------------------------------------------------ IF (PRESENT(lacc)) THEN lzacc = lacc ELSE lzacc = .FALSE. ENDIF izerror = 0 ! definition of the integration box: ! [ i_center-d_idx_x .. i_center+d_idx_x ] ! * [ j_center-d_idx_y .. j_center+d_idx_y ] ! * [ k_center-d_idx_z .. k_center+d_idx_z ] d_idx_x = 3 d_idx_y = 3 d_idx_z = 6 k_center = 30 ! Allocations: ALLOCATE( zeta ( 1:ie, 1:je, 1:ke) ) ALLOCATE( w_s ( 1:ie, 1:je, 1:ke) ) ALLOCATE( w_mean ( 1:ie, 1:je ) ) ALLOCATE( w2_mean ( 1:ie, 1:je ) ) ALLOCATE( zeta_mean ( 1:ie, 1:je ) ) ALLOCATE( zeta2_mean ( 1:ie, 1:je ) ) ALLOCATE( helic_mean ( 1:ie, 1:je ) ) !$acc data present (sdi_1, sdi_2, crlat,sqrtg_r_s,u,v,w) & !$acc create (zeta, w_s, w_mean, w2_mean, zeta_mean, & !$acc zeta2_mean, helic_mean, zeta_vert_mean, & !$acc w_crit_sdi2,kzdims) ! to prevent errors at the boundaries, set some fields to 0: !$acc kernels sdi_1(:,:) = 0.0_wp sdi_2(:,:) = 0.0_wp zeta(:,:,:) = 0.0_wp w_s(:,:,:) = 0.0_wp !$acc end kernels ! consistency checks: IF ( ( d_idx_x > nboundlines ) .OR. ( d_idx_y > nboundlines ) ) THEN yzerrmsg="integration box is too big in horizontal direction!" ! if such a big value for d_idx_x or d_idx_y is really needed, then you must increase ! nboundlines CALL model_abort (my_cart_id, 100, yzerrmsg, 'calc_sdi') END IF IF ( ( k_center - d_idx_z < 2 ) .OR. ( k_center + d_idx_z > ke ) ) THEN yzerrmsg="integration box is too big in vertical direction!" CALL model_abort (my_cart_id, 100, yzerrmsg, 'calc_sdi') END IF ! calculate vorticity and vertical velocity at scalar points: dx_aequ = r_earth * (pi/180.0_wp) * dlon dy = r_earth * (pi/180.0_wp) * dlat !$acc parallel DO k = k_center - d_idx_z, k_center + d_idx_z !$acc loop gang private(dx) DO j = jstart, jend dx = dx_aequ * crlat(j,1) !$acc loop vector DO i = istart, iend zeta(i,j,k ) = ( ( v(i+1,j, k,itl) + v(i+1,j-1,k,itl) ) & & - ( v(i-1,j, k,itl) + v(i-1,j-1,k,itl) ) ) & & * 0.5_wp / dx & & - ( ( u(i, j+1,k,itl) + u(i-1,j+1,k,itl) ) & & - ( u(i, j-1,k,itl) + u(i-1,j-1,k,itl) ) ) & & * 0.5_wp / dy w_s(i,j,k) = 0.5_wp * ( w(i,j,k,itl) + w(i,j,k-1,itl) ) END DO END DO END DO !$acc end parallel kzdims(1:24)=(/ke,ke,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) CALL exchg_boundaries & (50+nnew, sendbuf, isendbuflen, imp_reals, icomm_cart, num_compute, & ie, je, kzdims, jstartpar, jendpar, nbl_exchg, nboundlines, & my_cart_neigh, lperi_x, lperi_y, l2dim, & 20000+nexch_tag, .FALSE. , ncomm_type, izerror, yzerrmsg, & zeta(:,:,:), w_s(:,:,:), lacc=.TRUE.) ! (exchange of w_s would not be necessary, if it is calculated also at the boundary lines) ! --- calculate mean values over the integration box: ------ CALL mean_over_box( w_s, w_mean, k_center, d_idx_x, d_idx_y, d_idx_z, & crlat, sqrtg_r_s, ie, je, ke, istart, iend, jstart, & jend, lacc=.TRUE.) CALL mean_over_box( zeta, zeta_mean, k_center, d_idx_x, d_idx_y, d_idx_z, & crlat, sqrtg_r_s, ie, je, ke, istart, iend, jstart, & jend, lacc=.TRUE.) ! (no exchange needed for w_mean, zeta_mean) ! --- calculate covariances over the integration box: ----------- CALL mean_cov_over_box( w_s, w_mean, zeta, zeta_mean, helic_mean, & k_center, d_idx_x, d_idx_y, d_idx_z, crlat, & sqrtg_r_s, ie, je, ke, istart, iend, jstart, & jend, lacc=.TRUE.) CALL mean_cov_over_box( w_s, w_mean, w_s, w_mean, w2_mean, & k_center, d_idx_x, d_idx_y, d_idx_z, crlat, & sqrtg_r_s, ie, je, ke, istart, iend, jstart, & jend, lacc=.TRUE.) CALL mean_cov_over_box( zeta, zeta_mean, zeta, zeta_mean, zeta2_mean, & k_center, d_idx_x, d_idx_y, d_idx_z, crlat, & sqrtg_r_s, ie, je, ke, istart, iend, jstart, & jend, lacc=.TRUE.) ! calculate SDI_1, SDI_2: ! call to vectorized version of vert_avg CALL vert_avg( zeta_vert_mean,zeta, sqrtg_r_s, ie, je, ke, istart, iend, & jstart, jend, k_center, d_idx_z, lacc=.TRUE.) ! The meaning of 'w>0' in Wicker et al. is not completely clear, I assume ! the following: CALL vert_avg( w_crit_SDI2, w_s, sqrtg_r_s, ie, je, ke, istart, iend, & jstart, jend, k_center, d_idx_z, lacc=.TRUE.) !$acc parallel !$acc loop gang private(dx) DO j = jstart, jend dx = dx_aequ * crlat(j,1) !$acc loop vector DO i = istart, iend IF ( ( w2_mean(i,j) > EPS ) .AND. ( zeta2_mean(i,j) > EPS ) ) THEN helic_w_corr = helic_mean(i,j) / SQRT(w2_mean(i,j) * zeta2_mean(i,j)) sdi_1(i,j) = helic_w_corr * zeta_vert_mean(i,j) IF ( w_crit_SDI2(i,j) > 0 ) THEN sdi_2(i,j) = helic_w_corr * ABS( zeta_vert_mean(i,j) ) ELSE sdi_2(i,j) = 0.0_wp END IF ELSE sdi_1(i,j) = 0.0_wp sdi_2(i,j) = 0.0_wp END IF END DO END DO !$acc end parallel !$acc end data DEALLOCATE( zeta, w_s, w_mean, zeta_mean, w2_mean, zeta2_mean, helic_mean ) END SUBROUTINE calc_sdi !============================================================================== END MODULE src_output