From 1bba2bc776c5f85164aa789ff559561ba2ddf9d7 Mon Sep 17 00:00:00 2001 From: EricJames-NOAA Date: Fri, 5 Aug 2022 09:32:25 -0600 Subject: [PATCH] Merging EMC's latest code into RRFS_dev (#35) * NOAA GSL UPP updates (#413) * Turn on GSD cloud ceiling calculation for RRFS dev. * Updates to UPP for RRFS applications (#3) * Updates to UPP for RRFS applications: 1) Adding a RRFS-specific .xml control file and a corresponding .txt flat file. Note that script changes (pending) are needed to leverage the new flat file. However, this code will work in current real-time configurations. 2) Adding GSL experimental ceiling diagnostics, GSL visibility diagnostic, and GSL sea-level pressure reduction (MAPS). Also adding TKE and aerosol number concentrations. 3) Code clean-up for ceiling-related diagnostics; added comments, etc. 4) Removing several non-needed variables, originally inherited from FV3-SAR community configuration. * Updating UPP control files to specify GRIB2 generating center as "noaa_fsl_boulder" and the generating process as "hrrr". The "hrrr" specification is temporary, and will eventually be switched to "rrfs" once required changes to the "NCEPLIBS-g2tmpl" library are available. (#4) * Fix some out-of-bounds reads that caused the RRFS UPP to crash. (#5) * Adding README file (#7) * Adding README file to describe process of making a "flat" file. * Updates to README to improve explanation of input/output files. * Code to read in Flash Flood Guidance (FFG) and Average Recurrence Interval (ARI) precipitation datasets for comparison with model QPF within UPP. * Fixed a syntax error in SURFCE.f * Getting rid of GRIB1 output option to be consistent with rest of code. * Changing field numbers to avoid conflict with existing RRFS-dev1 fields. * Putting exceedance grids in flat files for testing in RRFS UPP. * Corrected the 1h and run total precip names for calculating exceedances in SURFCE.f * Bug fix in SURFCE.f if statements. * Removing changes to RQSTFLD.F since GRIB1 is no longer used in UPP. * Merging NOAA-GSL development on top of NOAA-EMC UPP for testing. * Correcting minor typos in SURFCE.f to allow testing. * Update code based on testing with RRFS cases. * Update part of the code based on current EMC develop branch for comparing the test results with the merged version.(#9) * Fixed several bugs in the code. * Modifications to SURFCE.f to check for existence of FFG files. * Bug fixes for FFG file existence check, and changes to handle rotated lat-lon grid interpolation for FFG * Bug fixes for FFG existence checks in SURFCE.f * Another bug fix for SURFCE.f * Updating XML and flat txt files to include a 65th vertical level to be consistent with updated FV3LAM model with higher model top. (#13) * Code cleanup for QPF - FFG comparison. Comparison put into subroutine. * Cleanup of SURFCE.f; moving the FFG comparisons into a subroutine. * Final cleanup of exceedance code for QPF vs FFG. * Removing some commented out variable declarations. * Additional cleanup recommended by Ming: we really only need two exceedance variables; one for 1h FFG and one for run total FFG exceedances. * Further cleanup of FFG code, simplifying to two fields (1h acc and run total acc) * Adding ARI comparison fields for 2y, 5y, 10y, and 100y ARIs. * Changes to output 9 soil levels from FV3LAM if we are running 9 level RUC LSM. * Adding flat txt file for UPP. * Commenting out the use of the ARI exceedances for now. We can switch them on later. * Bug fix in INITPOST_NETCDF.f : need to use both ncid2d and ncid3d in this subroutine! * Adding NOAA-GSL code changes on top of latest NOAA-EMC UPP. * Couple of bug fixes in NOAA-EMC code. Bugs were leading to PRMSL and -10C REFD being all zeroes. * Cleaning up code to get rid of unnecessary differences from EMC. * Putting all new GSL variables into EMC's unified post_avblflds.xml. Note that EMC's unified post_avblflds.xml does not validate using the avblflds Schema. * Updating postconfig-NT.txt file for GSL RRFS based on merged post_avblflds.xml file. * Adding RRFS control files to makefile. * Changing back scale for WEASD_ON_SURFACE to previous default, thanks to suggestion from Wen Meng. * Reverting name of cldfra based on feedback from Eric Aligo. * Reverting changes in fv3lam_post_avblflds.xml since GSL new variables are now included in post_avblflds.xml * Changing experimental ceiling level type from "ceiling" to "cloud_ceilng" * Updating 3drtma_postcntrl.xml with revised name for GSD_EXP_CEILING. This also affects postxconfig-NT-3drtma.txt. postxconfig-NT-fv3lam_rrfs.txt also changed due to changes in post_avblflds.xml * Introducing if statement for call of NGMSLP, to avoid calling unless it is needed. Co-authored-by: Ming.Hu Co-authored-by: Christina Holt <56881914+christinaholtNOAA@users.noreply.github.com> Co-authored-by: Christina Holt Co-authored-by: Jaymes Kenyon Co-authored-by: Samuel Trahan (NOAA contractor) <39415369+SamuelTrahanNOAA@users.noreply.github.com> * Doxygen for CALDWP.f * Further refinement. * Doxygen CALDRG.f (#424) * Doxygen for CALDRG.f * Delete CALDWP.f * Revert "Delete CALDWP.f" This reverts commit 575cd93f2a1b8d0f96df57164f077118dd131d26. * Sync changes from UPP for GFSV16 (#422) * Add gtg code as submodule. * Remove manage_externals. * Sync with the changes from GFSV16. * Add change logs for POSTGRB2TBL default setting. * Disable recursive checkout on gtg code (#427) * add option to build with GTG code or stubs (#430) * add option to build with GTG code or stubs * make IP optional depending on GTG option. * GTG code depends on a file that only resides in the gtg repo * fix a big boo-boo * move sorc/post_gtg.fd to sorc/ncep_post.fd/post_gtg.fd and update build path to GTG * correct the name of the submodule. fix mixed indents * move map_routines.F90 into the GTG src list * Add options in build script (#435) * Add command line arguments in compile_upp.sh for options, e.g. building with gtg code, building with wrfio stub code, turning on cmake verbose. * Remove legacy GNU make capability. * Clean up legacy read interfaces (#437) * Remove read interfaces INITPOST_GFS_NEMS, INITPOST_GFS_NEMS_MPIIO and INITPOST_GFS_NMM. * Change linking order for w3nco and nemsio * Remove INITPOST_GFS_NETCDF * Remove INITPOST_GFS_NEMS.f, INITPOST_GFS_NETCDF.f, INITPOST_NEMS.f, INITPOST_NEMS_MPIIO.f from UPP code. * Fix build failture. * Clean up legacy makefile * Clean up another two makefiles * Add back INITPOST_GFS_NETCDF * Port UPP develop branch on wcoss2 (#439) * Add changes for WCOSS2 Acorn. * Add changes for Dogwood. * Add changes for WCOSS2. * Change modulefile on wcoss2 in LUA format based on Kate's comments. * Add machine recognition for cactus and WCOSS1 P3.5 based on Eric's comments * Exception handling if anl input not found (#443) (#444) * modified: scripts/exgdas_atmos_nceppost.sh * modified: scripts/exgfs_atmos_nceppost.sh * Update regional FV3 read interface with parallel netcdf read (#441) * Changes for parallel netcdf read for regional FV3 interface * Clean up debugging code * Replace small with the one defined in params_mod based on Huiya's comments. * Update documentation to reflect updates to develop (fortran namelist/RQSTFLD removal) (#445) * exec is selectable for executable directory (#448) * Doxygen for CALGUST (#451) * Doxygen for CALDRG.f * This is part of Issue #392 Fixes the doxygen warnings in CALGUST.f Please review this subroutine. Thank you. * The fix in CALUPDHEL.f (#458) * Modify CALUPDHEL.f for restricting undefined grids in computation. * Update VERSION to 10.0.12. * Bug fix for SLLEVEL bound issue when not RUC LSM (#463) Co-authored-by: Tracy * Doxygen caldrg caldwcp calgust refinement (#464) * Further refinement to the tables and logs. * Further refinement to the tables and logs. (#455) * This is part of Issue #392 (#460) Fixes the doxygen warnings in CALHEL.f CALHEL2.f CALHEL3.f Please review this subroutine. Thank you. * Unify global and regional FV3 read interfaces (#453) * Unify the interfaces for reading FV3 outputs in netcdf. * Remove interface INITPOST_GFS_NETCDF_PARA. * Remove INITPOST_GFS_NETCDF.f. * Remove the capability of serial netcdf reading FV3 outputs. * Correct reading rswinc. * Remove duplication in CLDRAD.f. * Remove duplicated avgalbedo reading * Add changes for reading pwat from model. * Clean up commented out code * Clean up duplicated lines * Add ability to compile script to use non-intel compilers; add Cheyenne modulefiles for gnu and intel (#468) * Add cheyenne modulefile * Intel 19 --> 2021 * Add ability to specify compiler; move all existing modulefiles to ${name}_intel since they are all for intel compilers; add "cheyenne_gnu" modulefile * Revert move of intel modulefiles; now the implicit default for a modulefile is intel, only gnu and other compilers will have the compiler name appended to the modulefile * Allow for lua modulefiles with ".lua" appended * This is part of Issue #392 (#465) Fixes the doxygen warnings in CALLCL.f CALMCVG.f CALMICT.f * This is part of Issue #392 (#466) Fixes the doxygen warnings in CALPBL.f CALPBLREGIME.f CALPOT.f CALPW.f. * Doxygen in CALRAD_WCLOUD_newcrtm.f CALRCH.f CALSTRM.f CALTAU.f CALTHTE.f CALUPDHEL.f. (#467) * This is part of Issue #392. Fixes the doxygen warnings in CALRAD_WCLOUD_newcrtm.f CALRCH.f CALSTRM.f CALTAU.f CALTHTE.f CALUPDHEL.f. * Fixed typo. * Update to PR #458. * Doxygen in CALVOR.f, CALWXT_BOURG.f, CLDRAD.f, COLLECT.f, COLLECT_LOC.f, DEALLOCATE.f, and DEALLOCATE.f (#469) * This is part of Issue #392. Fixes the doxygen warnings in CALVOR.f, CALWXT_BOURG.f, CLDRAD.f, COLLECT.f, COLLECT_LOC.f, DEALLOCATE.f, and DEALLOCATE.f. * Fixed minor bug in CALVOR.f. * Update to PR#453. * More updates. * Doxygen in EXCH.f, FDLVL.f, FILL_PSETFLD.f, FRZLVL.f, and FRZLVL2.f. (#470) * This is part of Issue #392. Fixes the doxygen warnings in EXCH.f, FDLVL.f, FILL_PSETFLD.f, FRZLVL.f, and FRZLVL2.f. * Minor fix and Added new features from Ed's comments. * Format enhancement from Edward's comments. * Updated documentation. * Doxygen in GFSPOSTSIG.F NGMFLD.f OTLFT.f OTLIFT.f PARA_RANGE.f PROCESS.f and retrieve_index.f. (#477) * This is part of Issue #392. Fix the doxygen warnings in GFSPOSTSIG.F NGMFLD.f OTLFT.f OTLIFT.f PARA_RANGE.f PROCESS.f and retrieve_index.f. * Minor fix. * Update table for NGMFLD.f. * Doxygen in GET_BITS.f, GPVS.f, LFMFLD.f, LFMFLD_GFS.f, MDL2P.f, MDL2STD_P.f, MDL2THANDPV.f, and MSFPS.f. (#474) * This is part of Issue #392. Fixes the doxygen warnings in GET_BITS.f, GPVS.f, LFMFLD.f, LFMFLD_GFS.f, MDL2P.f, MDL2STD_P.f, MDL2THANDPV.f, and MSFPS.f. * Minor fix. * Doxygen in kinds_mod.F, native_endianness.f, UPP_MATH.f and UPP_PHYSICS.f. (#479) * This is part of Issue #392. Fixes the doxygen warnings in kinds_mod.F, native_endianness.f, UPP_MATH.f and UPP_PHYSICS.f. * Further enhancement from Ed's comment. * Bug fix in UPP build script on Catcus (#481) * Doxygen in SCLFLD.f SELECT_CHANNELS.f SET_OUTFLDS.f SETUP_SERVERS.f SMOOTH.f TRPAUS.f TRPAUS_NAM.f WETFRZLV.f WRFPOST.f and ZENSUN.f (#480) * This is part of Issue #392. Fixes the doxygen warnings in SCLFLD.f SELECT_CHANNELS.f SET_OUTFLDS.f SETUP_SERVERS.f SMOOTH.f TRPAUS.f TRPAUS_NAM.f WETFRZLV.f WRFPOST.f ZENSUN.f * Further enhancement from Ed's comment. * Update readme (#486) * Starting UPP version numbers with 10.0.0 for develop branch * Add codeowners file to develop * Update README * Formatting updates * update inline post supported applications * Additional updates to supported models Co-authored-by: Kate Fossell * Doxygen in GFSPOST.F (#476) * This is part of Issue #392. Fixes the doxygen warnings in GFSPOST.F and GFSPOSTSIG.F. * Testing:revert GFSPOST.F * Testing: Revert GFSPOSTSIG.F and test GFSPOST.F only. * Convert list to a table. * Add more document. * Add more document. * Add more document. * Fixed indentation. * Minor fixes. * Further refinement from Ed's comment. * Doxygen in INITPOST.F, INITPOST_GFS_NEMS_MPIIO, INITPOST_NEMS.f and INITPOST_NETCDF.f. (#473) * This is part of Issue #392. Fixes the doxygen warnings in INITPOST.F, INITPOST_GFS_NEMS_MPIIO, INITPOST_NEMS.f and INITPOST_NETCDF.f. * Minor fix. * Minor fix. * Further refinement from Ed's comments. * Minor bug fix. * This is part of Issue #392. (#487) Fixes the doxygen warnings in BOUND.f. * fix a bug in AOD calculation (#489) * fixed a bug in AOD calculation * add mie aod and surface dust pm10 * remove enddo in line 5211 in CLDRAD.f * parm updates for dust pm10 * increment version of develop (#502) Co-authored-by: Kate Fossell * Add camshe to codeowners for public docs and run script (#506) Co-authored-by: Kate Fossell * Update gfs itag files for in-line post. (#508) * Merge release/public-v3 (#509) * run_upp script got the following updates: -updated directory name -updated executable path -added error message for binarynemsiompiio option -added netcdfpara option * Further refinement from Tracy's comment. * Minor fix. * More minor change from Tracy. * Link update from Tracy. * Documentation updates for release * minor updates based on comments * minor revisions to documentation * Increment version for public release * update informat - only netcdfpara * Removed netcdf option and rename GFS input file names. * Minor change. Co-authored-by: kayee Co-authored-by: Tracy Co-authored-by: Kate Fossell * Documentation changes (#511) * Remove mention of Guassian grid for FV3 * Fix latest change to table * Remove app-specific tables * 2D Decomposition (#339) * Changes to support 2D Decomposition shape changes. Full I dimension remains in all arrays bu t SURFCE is altered to use isx:iex bounds which are equivalent to IM which is equivalent to 1:IM * test of commit only added one comment to PROCESS.f * comment test 2 * Added more routines to 2D decomposition * Changed isx and iex to ISTA and IEND in listed routines. ISTA had prior use in MDL2P.f and that needed changing. IEND had prior use in PARA_CONFIG, changed to IENDJ in PARA_CONFIG2 where needed PARA_CONFIG did not need changing * test commit of new base into clone * repair of a bunch of changed routines somehow corrupted by a merge 5/3/2021 * fixed 5/25 problem * added ctlblk change to support ista and iend partial I dimensons * added para_range2 to PARA_RANGE.f to support 2D decomposition * Modified MPI_FIRST.f to support a 2D decomposition but the actual numbers used remain the 1D special case and the changes just add two more indices for start and end I domains and logic to convert scatter counts and displacements to the product of the I and J subdomain sizes rather than I full domain x J subdomain. * Added support for halo settings of 2D boundaries i.e ista_2l to match the 1D analogs long present in the source 6/1/2021 * Added definitions for ista_2u, and ista_2u in MPI_FIRST.f * Reshaped arrays in MDL2FLD.f to support 2D decomposition. Modified TWO (only) loops to try thie * Remove TIMEF.f. * 20210702 JesseMeng modify MPI_FIRST.f MDLFLD.f for 2D decomposition * 20210706 BoCui modify INITPOST_GFS_NETCDF_PARA.f * 20210707 JesseMeng modified grib2_module.f for 2d decomposition * test version INITPOST_GFS_NETCDF_PARA.f * test version INITPOST_GFS_NETCDF_PARA.f and MPI_FIRST.f * 20210713 BoCui test INITPOST_GFS_NETCDF_PARA.f, MPI_FIRST.f and ALLOCATE_ALL.f * 20210713 BoCui test INITPOST_GFS_NETCDF_PARA.f, MPI_FIRST.f and ALLOCATE_ALL.f * 20210719 BoCui Modified CLDRAD.f for 2d decomposition * 20210816 Jesse Meng commit George's EXCH update for 1 layer 2D halos transforming * 20210816 Jesse Meng remove ifcore in EXCH * 20210903 Bo Cui update ALLOCATE_ALL.f after new merge from 'upstream/develop' * 20210903 Bo Cui Added new routines to 2D decomposition * 20210903 Jesse Meng fixed the ieql allocation bug in ALLOCATE_ALL.f * 20210904 Bo Cui fixed CLDRAD.f * 20210913 Jesse Meng commit progress of 2D decomposition * 20210917 Bo Cui add new routines to 2D decomposition * 20210917 Jesse Meng remove 4 legacy files * 20210917 Jesse Meng remove legacy code SLP_NMM EXCH2 * 20210917 Jesse Meng remove legacy code INITPOST_GFS_SIGIO.f INITPOST_GFS_NEMS.f * 20210917 Jesse Meng add INITPOST_GFS_NEMS.f back to avoid compiling error. * 20210930 Jesse Meng add George's itag/numx entry and progress on 2D decompose * 20211015 Jesse Meng progress on 2D DECOMPOSITION * 20211017 Bo Cui add new subroutines to UPP 2D decomposition * 20211026 Jesse Meng commit progress in 2D DECOMPOSITION * 20211026 Jesse Meng fix INITPOST_GFS_NETCDF_PARA.f for 2D DECOMPOSITION * 20211026 Jesse Meng update SURFCE.f for 2D DECOMPOSITION * 20211103 Jesse Meng commit progress of 2D DECOMPOSITION * 20211106 Bo Cui commit progress of 2D decomposition * 20211109 Jesse Meng updates for 2D DECOMPOSITION * 20211110 Jesse Meng updates in 2D DECOMPOSITION * 20211112 Jesse Meng updates for 2D DECOMPOSITION * 20211115 Jesse Meng updates for 2D DECOMPOSITION * 20211119 Jesse Meng updates for 2D DECOMPOSITION * 20211201 Jesse Meng move CALVOR to UPP_PHYSICS module; implement fullpole in MPI_FIRST * 20211202 Jesse Meng minor update of MPI_FIRST using mpi_allgatherv * 20211203 Jesse Meng implement fullpole in MDL2THANDPV and CALDIV * 20211207 Jesse Meng update MISCLN.f SURFCE.f * 20211208 Jesse Meng add parm/hafs_nosat files * 20211213 Bo Cui updates for 2D decomposition * 20211213 Jesse Meng update the merged 'upstream/develop' and 'post_2d_decomp' branch to 2d_decomp style * 20211215 Jesse Meng use i=0:im+1 for GFS in MPI_FIRST and EXCH * 20211216 Jesse Meng minor update UPP_PHYSICS for i=0:im+1 expansion * 20220104 Jesse Meng add George's minor fix in EXHC.f * 20220118 Jesse Meng commit George's cleaned up code. * 20220203 Jesse Meng - update MAPSSLP.f to be consistent with develop branch. * 20220222 Jesse Meng add checkcoords flag in EXCH.f to move around George's debug code. * 20220302 Jesse Meng Restrict computation from undefined grids * 20220304 Bo Cui Add a reset of numx=1 if remainder of num_procs/numx is not 0 * 20220310 Jesse Meng Add a reset of numx=1 if(numx>num_procs/2) * 20220322 Jesse Meng mpi_allgatherv change communicator to MPI_COMM_COMP * 20220328 Jesse Meng bug fix for passing 2d subarrays between subroutines * 20220328 Jesse Meng minor fix for CLDRAD call BOUND variable array size * 20220330 Jesse Meng fix cloud cover variabes full field collection in 2d decomp * 20220401 Jesse Meng minor fix for CALMCVG.f and update CALUPDHEL.f with develop * 20220414 BoCui sync and merge UPP/develop into post_2d_decomp (#7) * Added lambert conformal projection for FV3SAR and handled composite reflectivity correctly (#14) (#2) * exec is selectable for executable directory (#448) * Doxygen for CALGUST (#451) * Doxygen for CALDRG.f * This is part of Issue #392 Fixes the doxygen warnings in CALGUST.f Please review this subroutine. Thank you. * The fix in CALUPDHEL.f (#458) * Modify CALUPDHEL.f for restricting undefined grids in computation. * Update VERSION to 10.0.12. * Bug fix for SLLEVEL bound issue when not RUC LSM (#463) Co-authored-by: Tracy * Doxygen caldrg caldwcp calgust refinement (#464) * Further refinement to the tables and logs. * Further refinement to the tables and logs. (#455) * This is part of Issue #392 (#460) Fixes the doxygen warnings in CALHEL.f CALHEL2.f CALHEL3.f Please review this subroutine. Thank you. * Unify global and regional FV3 read interfaces (#453) * Unify the interfaces for reading FV3 outputs in netcdf. * Remove interface INITPOST_GFS_NETCDF_PARA. * Remove INITPOST_GFS_NETCDF.f. * Remove the capability of serial netcdf reading FV3 outputs. * Correct reading rswinc. * Remove duplication in CLDRAD.f. * Remove duplicated avgalbedo reading * Add changes for reading pwat from model. * Clean up commented out code * Clean up duplicated lines * Add ability to compile script to use non-intel compilers; add Cheyenne modulefiles for gnu and intel (#468) * Add cheyenne modulefile * Intel 19 --> 2021 * Add ability to specify compiler; move all existing modulefiles to ${name}_intel since they are all for intel compilers; add "cheyenne_gnu" modulefile * Revert move of intel modulefiles; now the implicit default for a modulefile is intel, only gnu and other compilers will have the compiler name appended to the modulefile * Allow for lua modulefiles with ".lua" appended * This is part of Issue #392 (#465) Fixes the doxygen warnings in CALLCL.f CALMCVG.f CALMICT.f * This is part of Issue #392 (#466) Fixes the doxygen warnings in CALPBL.f CALPBLREGIME.f CALPOT.f CALPW.f. * Doxygen in CALRAD_WCLOUD_newcrtm.f CALRCH.f CALSTRM.f CALTAU.f CALTHTE.f CALUPDHEL.f. (#467) * This is part of Issue #392. Fixes the doxygen warnings in CALRAD_WCLOUD_newcrtm.f CALRCH.f CALSTRM.f CALTAU.f CALTHTE.f CALUPDHEL.f. * Fixed typo. * Update to PR #458. * Doxygen in CALVOR.f, CALWXT_BOURG.f, CLDRAD.f, COLLECT.f, COLLECT_LOC.f, DEALLOCATE.f, and DEALLOCATE.f (#469) * This is part of Issue #392. Fixes the doxygen warnings in CALVOR.f, CALWXT_BOURG.f, CLDRAD.f, COLLECT.f, COLLECT_LOC.f, DEALLOCATE.f, and DEALLOCATE.f. * Fixed minor bug in CALVOR.f. * Update to PR#453. * More updates. * 20220411 Bo Cui 2D decompositio CALVOR.f and INITPOST_NETCDF.f * 20220411 Bo Cui update doxgen and global and regional FV3 read interface * 20220414 Bo Cui: remove read_netcdf_2d_scatter and read_netcdf_3d_scatter from INITPOST_NETCDF.f * 20220415 Bo Cui delete CALVOR.f, add exch of gdlon in INITPOST_NETCDF.f * 20220421 Bo Cui Doxygen in UPP_PHYSICS.f,add restriction run 2D decomp only for GFS/FV3R in WRFPOST.f Co-authored-by: WenMeng-NOAA <48260754+WenMeng-NOAA@users.noreply.github.com> Co-authored-by: Wen Meng Co-authored-by: Chan-Hoo.Jeon-NOAA <60152248+chan-hoo@users.noreply.github.com> Co-authored-by: kayeekayee Co-authored-by: Tracy Hertneky <39317287+hertneky@users.noreply.github.com> Co-authored-by: Tracy Co-authored-by: Michael Kavulich * 20220502 Bo Cui code cleanup * 20220512 Jesse Meng minor fix for INITPOST_GFS_NEMS_MPIIO.f calling EXCH * 20220525 Jesse Meng minor fix to 2d_decomp syntax * Update VERSION to 11.0.0 * 20220607 Jesse Meng add variable declaration block in PARA_RANGE.f * 20220608 Jesse Meng remove blank spaces in sorc/ncep_post.fd/AllGETHERV_GSD.f * Add 2D decomp overview documentation (#6) * Add 2D decomp overview documentation * Update 2D overview Co-authored-by: George Vandenberghe Co-authored-by: wx15gv Co-authored-by: wx22mj Co-authored-by: Bo Cui Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: Jesse.Meng Co-authored-by: BoCui-NOAA <53531984+BoCui-NOAA@users.noreply.github.com> Co-authored-by: Chan-Hoo.Jeon-NOAA <60152248+chan-hoo@users.noreply.github.com> Co-authored-by: kayeekayee Co-authored-by: Tracy Hertneky <39317287+hertneky@users.noreply.github.com> Co-authored-by: Tracy Co-authored-by: Michael Kavulich Co-authored-by: Jesse Meng Co-authored-by: Kate Fossell * Fix for absv computation in RRFS (#516) * read in dx/dy instead of calculating them (#523) * read in dx/dy instead of caculating them * add the change log for dxdy code change * change 2011 to 2022 in the change log * Upgrade intel/impi version to 2022.1.2 on Hera and Orion (#527) * Update modulefiles on hera. * tweaking hera.lua * Update modulefile on orion * add spack-based ci. (#528) * add spack-based ci. replace dependency on w3nco with w3emc. Update w3emc to 2.9.2 on all machines (wcoss2 is already at 2.9.2) * remove deprecated hera and orion env. modulefiles * update nemsio version to 2.5.4. Flush cache * First attempt to add RRFS_dev development on top of latest EMC develop branch * Geting rid of unnecesary changes in MISCLN.f * Making reading in of wet1 consistent with new netcdf parallel read. * Updating fix files. * Bringing in the latest EMC develop branch. * Cosmetic changes to be consistent with EMC's develop branch Co-authored-by: Ming.Hu Co-authored-by: Christina Holt <56881914+christinaholtNOAA@users.noreply.github.com> Co-authored-by: Christina Holt Co-authored-by: Jaymes Kenyon Co-authored-by: Samuel Trahan (NOAA contractor) <39415369+SamuelTrahanNOAA@users.noreply.github.com> Co-authored-by: kayee Co-authored-by: WenMeng-NOAA <48260754+WenMeng-NOAA@users.noreply.github.com> Co-authored-by: Rahul Mahajan Co-authored-by: lgannoaa <37596169+lgannoaa@users.noreply.github.com> Co-authored-by: Tracy Hertneky <39317287+hertneky@users.noreply.github.com> Co-authored-by: Chan-Hoo.Jeon-NOAA <60152248+chan-hoo@users.noreply.github.com> Co-authored-by: Tracy Co-authored-by: Michael Kavulich Co-authored-by: Kate Fossell Co-authored-by: Kate Fossell Co-authored-by: lipan-NOAA Co-authored-by: Tracy Co-authored-by: George Vandenberghe Co-authored-by: wx15gv Co-authored-by: wx22mj Co-authored-by: Bo Cui Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: wx22mj Co-authored-by: Jesse.Meng Co-authored-by: BoCui-NOAA <53531984+BoCui-NOAA@users.noreply.github.com> Co-authored-by: Jesse Meng Co-authored-by: LinZhu-NOAA --- .github/CODEOWNERS | 6 +- .github/workflows/build_and_test.yml | 66 - .github/workflows/gcc.yml | 96 + .github/workflows/intel.yml | 114 + .gitignore | 4 +- .gitmodules | 4 + CMakeLists.txt | 7 +- Externals.cfg | 9 - README.md | 69 +- VERSION | 2 +- ci/spack.yaml | 23 + cmake/PackageConfig.cmake.in | 2 +- docs/2D-decomp.md | 21 + docs/Acknowledgments.rst | 2 +- docs/AddNewVariable.rst | 86 +- docs/CodeOverview.rst | 37 +- docs/Doxyfile.in | 1 + docs/InputsOutputs.rst | 54 +- docs/Installation.rst | 72 +- docs/Introduction.rst | 38 +- docs/MRW_GFSPRS_table.csv | 188 - docs/MRW_GFSPRS_table.rst | 11 - docs/Running.rst | 8 +- docs/SRW_BGDAWP_table.csv | 258 -- docs/SRW_BGDAWP_table.rst | 11 - docs/SRW_BGRD3D_table.csv | 217 -- docs/SRW_BGRD3D_table.rst | 11 - docs/UFS_unified_variables_table.csv | 244 ++ docs/UFS_unified_variables_table.rst | 13 + jobs/JGLOBAL_ATMOS_NCEPPOST | 18 +- jobs/JGLOBAL_ATMOS_POST_MANAGER | 4 +- jobs/J_NCEPPOST | 5 - manage_externals/.dir_locals.el | 12 - manage_externals/.github/ISSUE_TEMPLATE.md | 6 - .../.github/PULL_REQUEST_TEMPLATE.md | 17 - manage_externals/.gitignore | 14 - manage_externals/.travis.yml | 32 - manage_externals/LICENSE.txt | 34 - manage_externals/README.md | 211 -- manage_externals/README_FIRST | 54 - manage_externals/checkout_externals | 36 - manage_externals/manic/__init__.py | 9 - manage_externals/manic/checkout.py | 409 --- .../manic/externals_description.py | 790 ---- manage_externals/manic/externals_status.py | 164 - manage_externals/manic/global_constants.py | 18 - manage_externals/manic/repository.py | 97 - manage_externals/manic/repository_factory.py | 29 - manage_externals/manic/repository_git.py | 790 ---- manage_externals/manic/repository_svn.py | 284 -- manage_externals/manic/sourcetree.py | 350 -- manage_externals/manic/utils.py | 330 -- manage_externals/test/.coveragerc | 7 - manage_externals/test/.gitignore | 7 - manage_externals/test/.pylint.rc | 426 --- manage_externals/test/Makefile | 124 - manage_externals/test/README.md | 77 - manage_externals/test/doc/.gitignore | 2 - manage_externals/test/doc/Makefile | 20 - manage_externals/test/doc/conf.py | 172 - manage_externals/test/doc/develop.rst | 202 - manage_externals/test/doc/index.rst | 22 - manage_externals/test/doc/testing.rst | 123 - .../test/repos/container.git/HEAD | 1 - .../test/repos/container.git/config | 6 - .../test/repos/container.git/description | 1 - .../test/repos/container.git/info/exclude | 6 - .../41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 | Bin 133 -> 0 bytes .../71/5b8f3e4afe1802a178e1d603af404ba45d59de | Bin 136 -> 0 bytes .../b0/f87705e2b9601cb831878f3d51efa78b910d7b | Bin 89 -> 0 bytes .../f9/e08370a737e941de6f6492e3f427c2ef4c1a03 | Bin 81 -> 0 bytes .../repos/container.git/refs/heads/master | 1 - manage_externals/test/repos/error/readme.txt | 3 - .../test/repos/mixed-cont-ext.git/HEAD | 1 - .../test/repos/mixed-cont-ext.git/config | 6 - .../test/repos/mixed-cont-ext.git/description | 1 - .../repos/mixed-cont-ext.git/info/exclude | 6 - .../00/437ac2000d5f06fb8a572a01a5bbdae98b17cb | Bin 172 -> 0 bytes .../01/97458f2dbe5fcd6bc44fa46983be0a30282379 | Bin 171 -> 0 bytes .../06/ea30b03ffa2f8574705f8b9583f7ca7e2dccf7 | Bin 136 -> 0 bytes .../14/368b701616a8c53820b610414a4b9a07540cf6 | 1 - .../15/2b57e1cf23721cd17ff681cb9276e3fb9fc091 | 2 - .../1f/01fa46c17b1f38b37e6259f6e9d041bda3144f | Bin 167 -> 0 bytes .../37/f0e70b609adc90f4c09ee21d82ed1d79c81d69 | Bin 89 -> 0 bytes .../38/9a2b876b8965d3c91a3db8d28a483eaf019d5c | Bin 130 -> 0 bytes .../41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 | Bin 133 -> 0 bytes .../6e/9f4baa6e94a0af4e094836c2eb55ccedef5fc4 | Bin 129 -> 0 bytes .../6f/c379457ecb4e576a13c7610ae1fa73f845ee6a | 1 - .../93/a159deb9175bfeb2820a0006ddd92d78131332 | Bin 169 -> 0 bytes .../95/80ecc12f16334ce44e42287d5d46f927bb7b75 | 1 - .../a9/288dcd8a719a1f4ed3cba43a2a387ae7cd60fd | Bin 130 -> 0 bytes .../e8/ea32a11d30ee703f6f661ae7c2376f4ab84d38 | Bin 130 -> 0 bytes .../fd/15a5ad5204356229c60a831d2a8120a43ac901 | 2 - .../mixed-cont-ext.git/refs/heads/master | 1 - .../mixed-cont-ext.git/refs/heads/new-feature | 1 - .../test/repos/simple-ext-fork.git/HEAD | 1 - .../test/repos/simple-ext-fork.git/config | 8 - .../repos/simple-ext-fork.git/description | 1 - .../repos/simple-ext-fork.git/info/exclude | 6 - .../00/fd13e76189f9134b0506b4b8ed3172723b467f | Bin 89 -> 0 bytes .../0b/15e8af3d4615b42314216efeae3fff184046a8 | Bin 89 -> 0 bytes .../0b/67df4e7e8e6e1c6e401542738b352d18744677 | Bin 167 -> 0 bytes .../11/a76e3d9a67313dec7ce1230852ab5c86352c5c | 2 - .../16/5506a7408a482f50493434e13fffeb44af893f | Bin 89 -> 0 bytes .../24/4386e788c9bc608613e127a329c742450a60e4 | Bin 164 -> 0 bytes .../32/7e97d86e941047d809dba58f2804740c6c30cf | Bin 89 -> 0 bytes .../36/418b4e5665956a90725c9a1b5a8e551c5f3d48 | Bin 159 -> 0 bytes .../3d/7099c35404ae6c8640ce263b38bef06e98cc26 | 2 - .../3d/ec1fdf8e2f5edba28148c5db2fe8d7a842360b | 2 - .../41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 | Bin 133 -> 0 bytes .../4d/837135915ed93eed6fff6b439f284ce317296f | Bin 89 -> 0 bytes .../56/175e017ad38bf3d33d74b6bd7c74624b28466a | Bin 89 -> 0 bytes .../5f/1d4786d12e52d7ab28d2f2f1118c1059a9f1ae | Bin 93 -> 0 bytes .../67/136e5ab4d5c1c65d10c8048763b96b0e53c1d6 | Bin 165 -> 0 bytes .../7b/0bd630ac13865735a1dff3437a137d8ab50663 | Bin 119 -> 0 bytes .../88/cf20868e0cc445f5642a480ed034c71e0d7e9f | 2 - .../8d/2b3b35126224c975d23f109aa1e3cbac452989 | 2 - .../9b/75494003deca69527bb64bcaa352e801611dd2 | Bin 138 -> 0 bytes .../a2/2a5da9119328ea6d693f88861457c07e14ac04 | 1 - .../a4/2fe9144f5707bc1e9515ce1b44681f7aba6f95 | 3 - .../b9/3737be3ea6b19f6255983748a0a0f4d622f936 | Bin 89 -> 0 bytes .../c5/32bc8fde96fa63103a52057f0baffcc9f00c6b | 1 - .../c5/b315915742133dbdfbeed0753e481b55c1d364 | 1 - .../f2/68d4e56d067da9bd1d85e55bdc40a8bd2b0bca | 1 - .../repos/simple-ext-fork.git/packed-refs | 5 - .../simple-ext-fork.git/refs/heads/feature2 | 1 - .../refs/tags/abandoned-feature | 1 - .../refs/tags/forked-feature-v1 | 1 - .../test/repos/simple-ext.git/HEAD | 1 - .../test/repos/simple-ext.git/config | 6 - .../test/repos/simple-ext.git/description | 1 - .../test/repos/simple-ext.git/info/exclude | 6 - .../00/fd13e76189f9134b0506b4b8ed3172723b467f | Bin 89 -> 0 bytes .../09/0e1034746b2c865f7b0280813dbf4061a700e8 | Bin 164 -> 0 bytes .../0b/15e8af3d4615b42314216efeae3fff184046a8 | Bin 89 -> 0 bytes .../11/a76e3d9a67313dec7ce1230852ab5c86352c5c | 2 - .../31/dbcd6de441e671a467ef317146539b7ffabb11 | Bin 90 -> 0 bytes .../36/418b4e5665956a90725c9a1b5a8e551c5f3d48 | Bin 159 -> 0 bytes .../41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 | Bin 133 -> 0 bytes .../60/b1cc1a38d63a4bcaa1e767262bbe23dbf9f5f5 | 2 - .../63/a99393d1baff97ccef967af30380659867b139 | 1 - .../95/3256da5612fcd9263590a353bc18c6f224e74f | 1 - .../9b/75494003deca69527bb64bcaa352e801611dd2 | Bin 138 -> 0 bytes .../a2/2a5da9119328ea6d693f88861457c07e14ac04 | 1 - .../c5/b315915742133dbdfbeed0753e481b55c1d364 | 1 - .../df/312890f93ba4d2c694208599b665c4a08afeff | Bin 89 -> 0 bytes .../repos/simple-ext.git/refs/heads/feature2 | 1 - .../repos/simple-ext.git/refs/heads/feature3 | 1 - .../repos/simple-ext.git/refs/heads/master | 1 - .../test/repos/simple-ext.git/refs/tags/tag1 | 1 - manage_externals/test/requirements.txt | 5 - manage_externals/test/test_sys_checkout.py | 1827 --------- .../test/test_sys_repository_git.py | 238 -- .../test/test_unit_externals_description.py | 401 -- .../test/test_unit_externals_status.py | 299 -- manage_externals/test/test_unit_repository.py | 197 - .../test/test_unit_repository_git.py | 807 ---- .../test/test_unit_repository_svn.py | 501 --- manage_externals/test/test_unit_utils.py | 350 -- modulefiles/cheyenne | 39 + modulefiles/cheyenne_gnu | 40 + modulefiles/hera | 35 - modulefiles/hera.lua | 58 + modulefiles/jet | 3 +- modulefiles/orion | 35 - modulefiles/orion.lua | 58 + modulefiles/post/v8.0.0-cray-intel | 60 - modulefiles/post/v8.0.0-hera | 55 - modulefiles/post/v8.0.0-jet | 52 - modulefiles/post/v8.0.0-odin | 87 - modulefiles/post/v8.0.0-orion | 56 - modulefiles/post/v8.0.0-stampede | 54 - modulefiles/post/v8.0.0-wcoss | 45 - modulefiles/post/v8.0.0-wcoss_dell_p3 | 54 - modulefiles/s4 | 3 +- modulefiles/upp/lib-cray-intel | 57 - modulefiles/upp/lib-hera | 52 - modulefiles/upp/lib-jet | 52 - modulefiles/upp/lib-orion | 53 - modulefiles/upp/lib-wcoss | 54 - modulefiles/upp/lib-wcoss_dell_p3 | 53 - modulefiles/wcoss2.lua | 54 + modulefiles/wcoss_cray | 3 +- modulefiles/wcoss_dell_p3 | 3 +- parm/fv3lam_rrfs.xml | 8 +- parm/post_avblflds.xml | 7 +- parm/post_tag_gfs128 | 3 + parm/post_tag_gfs65 | 3 + parm/postcntrl_gefs_chem.xml | 6 + scripts/exgdas_atmos_nceppost.sh | 12 +- scripts/exgfs_atmos_nceppost.sh | 75 +- scripts/exglobal_atmos_pmgr.sh | 2 +- scripts/run_upp | 58 +- sorc/build_ncep_post.sh | 132 - sorc/ncep_post.fd/ALLOCATE_ALL.f | 1029 +++--- sorc/ncep_post.fd/AVIATION.f | 103 +- sorc/ncep_post.fd/AllGETHERV_GSD.f | 9 +- sorc/ncep_post.fd/BNDLYR.f | 57 +- sorc/ncep_post.fd/BOUND.f | 70 +- sorc/ncep_post.fd/CALDRG.f | 71 +- sorc/ncep_post.fd/CALDWP.f | 67 +- sorc/ncep_post.fd/CALGUST.f | 80 +- sorc/ncep_post.fd/CALHEL.f | 145 +- sorc/ncep_post.fd/CALHEL2.f | 158 +- sorc/ncep_post.fd/CALHEL3.f | 154 +- sorc/ncep_post.fd/CALLCL.f | 89 +- sorc/ncep_post.fd/CALMCVG.f | 131 +- sorc/ncep_post.fd/CALMICT.f | 203 +- sorc/ncep_post.fd/CALPBL.f | 87 +- sorc/ncep_post.fd/CALPBLREGIME.f | 77 +- sorc/ncep_post.fd/CALPOT.f | 62 +- sorc/ncep_post.fd/CALPW.f | 158 +- sorc/ncep_post.fd/CALRAD_WCLOUD_newcrtm.f | 159 +- sorc/ncep_post.fd/CALRCH.f | 76 +- sorc/ncep_post.fd/CALSTRM.f | 70 +- sorc/ncep_post.fd/CALTAU.f | 84 +- sorc/ncep_post.fd/CALTHTE.f | 71 +- sorc/ncep_post.fd/CALUPDHEL.f | 71 +- sorc/ncep_post.fd/CALVESSEL.f | 14 +- sorc/ncep_post.fd/CALVIS.f | 10 +- sorc/ncep_post.fd/CALVIS_GSD.f | 11 +- sorc/ncep_post.fd/CALVOR.f | 937 ----- sorc/ncep_post.fd/CALWXT.f | 34 +- sorc/ncep_post.fd/CALWXT_BOURG.f | 132 +- sorc/ncep_post.fd/CALWXT_DOMINANT.f | 18 +- sorc/ncep_post.fd/CALWXT_EXPLICIT.f | 15 +- sorc/ncep_post.fd/CALWXT_RAMER.f | 26 +- sorc/ncep_post.fd/CALWXT_REVISED.f | 27 +- sorc/ncep_post.fd/CLDRAD.f | 1159 +++--- sorc/ncep_post.fd/CLMAX.f | 13 +- sorc/ncep_post.fd/CMakeLists.txt | 44 +- sorc/ncep_post.fd/COLLECT.f | 44 +- sorc/ncep_post.fd/COLLECT_LOC.f | 162 +- sorc/ncep_post.fd/CTLBLK.f | 21 +- sorc/ncep_post.fd/DEALLOCATE.f | 47 +- sorc/ncep_post.fd/DEWPOINT.f | 96 +- sorc/ncep_post.fd/ETAMP_Q2F.f | 9 +- sorc/ncep_post.fd/EXCH.f | 437 ++- sorc/ncep_post.fd/EXCH2.f | 72 - sorc/ncep_post.fd/FDLVL.f | 445 +-- sorc/ncep_post.fd/FILL_PSETFLD.f | 53 +- sorc/ncep_post.fd/FIXED.f | 63 +- sorc/ncep_post.fd/FRZLVL.f | 108 +- sorc/ncep_post.fd/FRZLVL2.f | 112 +- sorc/ncep_post.fd/GET_BITS.f | 142 +- sorc/ncep_post.fd/GFSPOST.F | 691 ++-- sorc/ncep_post.fd/GFSPOSTSIG.F | 341 +- sorc/ncep_post.fd/GPVS.f | 170 +- sorc/ncep_post.fd/ICAOHEIGHT.f | 8 +- sorc/ncep_post.fd/INITPOST.F | 64 +- sorc/ncep_post.fd/INITPOST_GFS_NEMS.f | 3264 ----------------- sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f | 221 +- sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f | 2761 -------------- sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f | 2648 ------------- sorc/ncep_post.fd/INITPOST_NEMS.f | 53 +- sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f | 2464 ------------- sorc/ncep_post.fd/INITPOST_NETCDF.f | 2087 ++++++----- sorc/ncep_post.fd/INITPOST_NMM.f | 2643 ------------- sorc/ncep_post.fd/LFMFLD.f | 117 +- sorc/ncep_post.fd/LFMFLD_GFS.f | 119 +- sorc/ncep_post.fd/MAPSSLP.f | 15 +- sorc/ncep_post.fd/MDL2AGL.f | 186 +- sorc/ncep_post.fd/MDL2P.f | 856 +++-- sorc/ncep_post.fd/MDL2SIGMA.f | 166 +- sorc/ncep_post.fd/MDL2SIGMA2.f | 18 +- sorc/ncep_post.fd/MDL2STD_P.f | 174 +- sorc/ncep_post.fd/MDL2THANDPV.f | 435 ++- sorc/ncep_post.fd/MDLFLD.f | 940 ++--- sorc/ncep_post.fd/MISCLN.f | 1373 +++---- sorc/ncep_post.fd/MIXLEN.f | 24 +- sorc/ncep_post.fd/MPI_FIRST.f | 317 +- sorc/ncep_post.fd/MSFPS.f | 35 +- sorc/ncep_post.fd/NGMFLD.f | 138 +- sorc/ncep_post.fd/NGMSLP.f | 5 +- sorc/ncep_post.fd/OTLFT.f | 82 +- sorc/ncep_post.fd/OTLIFT.f | 72 +- sorc/ncep_post.fd/PARA_RANGE.f | 82 +- sorc/ncep_post.fd/PROCESS.f | 89 +- sorc/ncep_post.fd/SCLFLD.f | 68 +- sorc/ncep_post.fd/SELECT_CHANNELS.f | 40 +- sorc/ncep_post.fd/SETUP_SERVERS.f | 70 +- sorc/ncep_post.fd/SET_OUTFLDS.f | 58 +- sorc/ncep_post.fd/SLP_NMM.f | 411 --- sorc/ncep_post.fd/SLP_new.f | 51 +- sorc/ncep_post.fd/SMOOTH.f | 139 +- sorc/ncep_post.fd/SURFCE.f | 1372 +++---- sorc/ncep_post.fd/TRPAUS.f | 87 +- sorc/ncep_post.fd/TRPAUS_NAM.f | 80 +- sorc/ncep_post.fd/TTBLEX.f | 18 +- sorc/ncep_post.fd/UPP_MATH.f | 148 +- sorc/ncep_post.fd/UPP_PHYSICS.f | 1880 +++++++--- sorc/ncep_post.fd/VRBLS2D_mod.f | 4 +- sorc/ncep_post.fd/WETBULB.f | 26 +- sorc/ncep_post.fd/WETFRZLVL.f | 86 +- sorc/ncep_post.fd/WRFPOST.f | 280 +- sorc/ncep_post.fd/ZENSUN.f | 130 +- sorc/ncep_post.fd/build_upp_lib.sh | 54 - sorc/ncep_post.fd/grib2_module.f | 43 +- sorc/ncep_post.fd/kinds_mod.F | 61 +- sorc/ncep_post.fd/makefile | 258 -- sorc/ncep_post.fd/makefile_dtc | 130 - sorc/ncep_post.fd/makefile_lib | 146 - sorc/ncep_post.fd/makefile_module | 126 - sorc/ncep_post.fd/native_endianness.f | 120 +- sorc/ncep_post.fd/post_gtg.fd | 1 + sorc/ncep_post.fd/retrieve_index.f | 45 +- tests/compile_upp.sh | 79 +- tests/detect_machine.sh | 40 +- ush/fv3gfs_downstream_nems.sh | 4 +- ush/gfs_nceppost.sh | 10 +- 310 files changed, 11760 insertions(+), 37218 deletions(-) delete mode 100644 .github/workflows/build_and_test.yml create mode 100644 .github/workflows/gcc.yml create mode 100644 .github/workflows/intel.yml delete mode 100644 Externals.cfg create mode 100644 ci/spack.yaml create mode 100644 docs/2D-decomp.md delete mode 100644 docs/MRW_GFSPRS_table.csv delete mode 100644 docs/MRW_GFSPRS_table.rst delete mode 100644 docs/SRW_BGDAWP_table.csv delete mode 100644 docs/SRW_BGDAWP_table.rst delete mode 100644 docs/SRW_BGRD3D_table.csv delete mode 100644 docs/SRW_BGRD3D_table.rst create mode 100644 docs/UFS_unified_variables_table.csv create mode 100644 docs/UFS_unified_variables_table.rst delete mode 100644 manage_externals/.dir_locals.el delete mode 100644 manage_externals/.github/ISSUE_TEMPLATE.md delete mode 100644 manage_externals/.github/PULL_REQUEST_TEMPLATE.md delete mode 100644 manage_externals/.gitignore delete mode 100644 manage_externals/.travis.yml delete mode 100644 manage_externals/LICENSE.txt delete mode 100644 manage_externals/README.md delete mode 100644 manage_externals/README_FIRST delete mode 100755 manage_externals/checkout_externals delete mode 100644 manage_externals/manic/__init__.py delete mode 100755 manage_externals/manic/checkout.py delete mode 100644 manage_externals/manic/externals_description.py delete mode 100644 manage_externals/manic/externals_status.py delete mode 100644 manage_externals/manic/global_constants.py delete mode 100644 manage_externals/manic/repository.py delete mode 100644 manage_externals/manic/repository_factory.py delete mode 100644 manage_externals/manic/repository_git.py delete mode 100644 manage_externals/manic/repository_svn.py delete mode 100644 manage_externals/manic/sourcetree.py delete mode 100644 manage_externals/manic/utils.py delete mode 100644 manage_externals/test/.coveragerc delete mode 100644 manage_externals/test/.gitignore delete mode 100644 manage_externals/test/.pylint.rc delete mode 100644 manage_externals/test/Makefile delete mode 100644 manage_externals/test/README.md delete mode 100644 manage_externals/test/doc/.gitignore delete mode 100644 manage_externals/test/doc/Makefile delete mode 100644 manage_externals/test/doc/conf.py delete mode 100644 manage_externals/test/doc/develop.rst delete mode 100644 manage_externals/test/doc/index.rst delete mode 100644 manage_externals/test/doc/testing.rst delete mode 100644 manage_externals/test/repos/container.git/HEAD delete mode 100644 manage_externals/test/repos/container.git/config delete mode 100644 manage_externals/test/repos/container.git/description delete mode 100644 manage_externals/test/repos/container.git/info/exclude delete mode 100644 manage_externals/test/repos/container.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 delete mode 100644 manage_externals/test/repos/container.git/objects/71/5b8f3e4afe1802a178e1d603af404ba45d59de delete mode 100644 manage_externals/test/repos/container.git/objects/b0/f87705e2b9601cb831878f3d51efa78b910d7b delete mode 100644 manage_externals/test/repos/container.git/objects/f9/e08370a737e941de6f6492e3f427c2ef4c1a03 delete mode 100644 manage_externals/test/repos/container.git/refs/heads/master delete mode 100644 manage_externals/test/repos/error/readme.txt delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/HEAD delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/config delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/description delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/info/exclude delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/00/437ac2000d5f06fb8a572a01a5bbdae98b17cb delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/01/97458f2dbe5fcd6bc44fa46983be0a30282379 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/06/ea30b03ffa2f8574705f8b9583f7ca7e2dccf7 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/14/368b701616a8c53820b610414a4b9a07540cf6 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/15/2b57e1cf23721cd17ff681cb9276e3fb9fc091 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/1f/01fa46c17b1f38b37e6259f6e9d041bda3144f delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/37/f0e70b609adc90f4c09ee21d82ed1d79c81d69 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/38/9a2b876b8965d3c91a3db8d28a483eaf019d5c delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/6e/9f4baa6e94a0af4e094836c2eb55ccedef5fc4 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/6f/c379457ecb4e576a13c7610ae1fa73f845ee6a delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/93/a159deb9175bfeb2820a0006ddd92d78131332 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/95/80ecc12f16334ce44e42287d5d46f927bb7b75 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/a9/288dcd8a719a1f4ed3cba43a2a387ae7cd60fd delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/e8/ea32a11d30ee703f6f661ae7c2376f4ab84d38 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/objects/fd/15a5ad5204356229c60a831d2a8120a43ac901 delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/refs/heads/master delete mode 100644 manage_externals/test/repos/mixed-cont-ext.git/refs/heads/new-feature delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/HEAD delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/config delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/description delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/info/exclude delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/00/fd13e76189f9134b0506b4b8ed3172723b467f delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/0b/15e8af3d4615b42314216efeae3fff184046a8 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/0b/67df4e7e8e6e1c6e401542738b352d18744677 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/11/a76e3d9a67313dec7ce1230852ab5c86352c5c delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/16/5506a7408a482f50493434e13fffeb44af893f delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/24/4386e788c9bc608613e127a329c742450a60e4 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/32/7e97d86e941047d809dba58f2804740c6c30cf delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/36/418b4e5665956a90725c9a1b5a8e551c5f3d48 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/3d/7099c35404ae6c8640ce263b38bef06e98cc26 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/3d/ec1fdf8e2f5edba28148c5db2fe8d7a842360b delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/4d/837135915ed93eed6fff6b439f284ce317296f delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/56/175e017ad38bf3d33d74b6bd7c74624b28466a delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/5f/1d4786d12e52d7ab28d2f2f1118c1059a9f1ae delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/67/136e5ab4d5c1c65d10c8048763b96b0e53c1d6 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/7b/0bd630ac13865735a1dff3437a137d8ab50663 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/88/cf20868e0cc445f5642a480ed034c71e0d7e9f delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/8d/2b3b35126224c975d23f109aa1e3cbac452989 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/9b/75494003deca69527bb64bcaa352e801611dd2 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/a2/2a5da9119328ea6d693f88861457c07e14ac04 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/a4/2fe9144f5707bc1e9515ce1b44681f7aba6f95 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/b9/3737be3ea6b19f6255983748a0a0f4d622f936 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/c5/32bc8fde96fa63103a52057f0baffcc9f00c6b delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/c5/b315915742133dbdfbeed0753e481b55c1d364 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/objects/f2/68d4e56d067da9bd1d85e55bdc40a8bd2b0bca delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/packed-refs delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/refs/heads/feature2 delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/refs/tags/abandoned-feature delete mode 100644 manage_externals/test/repos/simple-ext-fork.git/refs/tags/forked-feature-v1 delete mode 100644 manage_externals/test/repos/simple-ext.git/HEAD delete mode 100644 manage_externals/test/repos/simple-ext.git/config delete mode 100644 manage_externals/test/repos/simple-ext.git/description delete mode 100644 manage_externals/test/repos/simple-ext.git/info/exclude delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/00/fd13e76189f9134b0506b4b8ed3172723b467f delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/09/0e1034746b2c865f7b0280813dbf4061a700e8 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/0b/15e8af3d4615b42314216efeae3fff184046a8 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/11/a76e3d9a67313dec7ce1230852ab5c86352c5c delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/31/dbcd6de441e671a467ef317146539b7ffabb11 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/36/418b4e5665956a90725c9a1b5a8e551c5f3d48 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/60/b1cc1a38d63a4bcaa1e767262bbe23dbf9f5f5 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/63/a99393d1baff97ccef967af30380659867b139 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/95/3256da5612fcd9263590a353bc18c6f224e74f delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/9b/75494003deca69527bb64bcaa352e801611dd2 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/a2/2a5da9119328ea6d693f88861457c07e14ac04 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/c5/b315915742133dbdfbeed0753e481b55c1d364 delete mode 100644 manage_externals/test/repos/simple-ext.git/objects/df/312890f93ba4d2c694208599b665c4a08afeff delete mode 100644 manage_externals/test/repos/simple-ext.git/refs/heads/feature2 delete mode 100644 manage_externals/test/repos/simple-ext.git/refs/heads/feature3 delete mode 100644 manage_externals/test/repos/simple-ext.git/refs/heads/master delete mode 100644 manage_externals/test/repos/simple-ext.git/refs/tags/tag1 delete mode 100644 manage_externals/test/requirements.txt delete mode 100644 manage_externals/test/test_sys_checkout.py delete mode 100644 manage_externals/test/test_sys_repository_git.py delete mode 100644 manage_externals/test/test_unit_externals_description.py delete mode 100644 manage_externals/test/test_unit_externals_status.py delete mode 100644 manage_externals/test/test_unit_repository.py delete mode 100644 manage_externals/test/test_unit_repository_git.py delete mode 100644 manage_externals/test/test_unit_repository_svn.py delete mode 100644 manage_externals/test/test_unit_utils.py create mode 100644 modulefiles/cheyenne create mode 100644 modulefiles/cheyenne_gnu delete mode 100755 modulefiles/hera create mode 100644 modulefiles/hera.lua mode change 100755 => 100644 modulefiles/jet delete mode 100755 modulefiles/orion create mode 100644 modulefiles/orion.lua delete mode 100644 modulefiles/post/v8.0.0-cray-intel delete mode 100644 modulefiles/post/v8.0.0-hera delete mode 100644 modulefiles/post/v8.0.0-jet delete mode 100644 modulefiles/post/v8.0.0-odin delete mode 100755 modulefiles/post/v8.0.0-orion delete mode 100644 modulefiles/post/v8.0.0-stampede delete mode 100644 modulefiles/post/v8.0.0-wcoss delete mode 100644 modulefiles/post/v8.0.0-wcoss_dell_p3 delete mode 100755 modulefiles/upp/lib-cray-intel delete mode 100755 modulefiles/upp/lib-hera delete mode 100755 modulefiles/upp/lib-jet delete mode 100755 modulefiles/upp/lib-orion delete mode 100755 modulefiles/upp/lib-wcoss delete mode 100755 modulefiles/upp/lib-wcoss_dell_p3 create mode 100644 modulefiles/wcoss2.lua mode change 100755 => 100644 modulefiles/wcoss_cray mode change 100755 => 100644 modulefiles/wcoss_dell_p3 delete mode 100755 sorc/build_ncep_post.sh delete mode 100644 sorc/ncep_post.fd/CALVOR.f delete mode 100644 sorc/ncep_post.fd/EXCH2.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NEMS.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f delete mode 100644 sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f delete mode 100644 sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f delete mode 100644 sorc/ncep_post.fd/INITPOST_NMM.f delete mode 100644 sorc/ncep_post.fd/SLP_NMM.f delete mode 100755 sorc/ncep_post.fd/build_upp_lib.sh delete mode 100644 sorc/ncep_post.fd/makefile delete mode 100644 sorc/ncep_post.fd/makefile_dtc delete mode 100644 sorc/ncep_post.fd/makefile_lib delete mode 100644 sorc/ncep_post.fd/makefile_module create mode 160000 sorc/ncep_post.fd/post_gtg.fd diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 962217602..9db52d085 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -8,7 +8,7 @@ * @WenMeng-NOAA -# DTC support for public releases and documentation -docs/* @hertneky @fossell -scripts/run_upp @hertneky @fossell +# Support for public releases and documentation +docs/* @hertneky @fossell @camshe +scripts/run_upp @hertneky @fossell @camshe diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml deleted file mode 100644 index aef646eb6..000000000 --- a/.github/workflows/build_and_test.yml +++ /dev/null @@ -1,66 +0,0 @@ -name: Build and Test -on: [push, pull_request] - -jobs: - build: - runs-on: ubuntu-20.04 - env: - FC: gfortran-9 - CC: gcc-9 - - steps: - - name: install-dependencies - run: | - sudo apt-get update - sudo apt-get install libmpich-dev - sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config - sudo apt-get install libpng-dev - sudo apt-get install libjpeg-dev - sudo apt-get install doxygen - - - name: checkout-jasper - uses: actions/checkout@v2 - with: - repository: jasper-software/jasper - path: jasper - ref: version-2.0.22 - - - name: build-jasper - run: | - cd jasper - mkdir build-jasper && cd build-jasper - cmake .. -DCMAKE_INSTALL_PREFIX=~ - make -j2 - make install - - - name: checkout-nceplibs - uses: actions/checkout@v2 - with: - repository: NOAA-EMC/NCEPLIBS - path: nceplibs - ref: v1.2.0 - - - name: build-nceplibs - run: | - cd nceplibs - mkdir build && cd build - cmake .. -DCMAKE_INSTALL_PREFIX=~ -DFLAT=ON -DBUILD_POST=OFF - make -j2 - - - name: checkout-post - uses: actions/checkout@v2 - with: - path: post - - - name: build-post - run: | - cd post - mkdir build && cd build - cmake .. -DCMAKE_PREFIX_PATH=~ -DENABLE_DOCS=ON - make -j2 - - - - - - diff --git a/.github/workflows/gcc.yml b/.github/workflows/gcc.yml new file mode 100644 index 000000000..da033fa71 --- /dev/null +++ b/.github/workflows/gcc.yml @@ -0,0 +1,96 @@ +name: GCC Linux Build +on: [push, pull_request, workflow_dispatch] + + +# Use custom shell with -l so .bash_profile is sourced +# without having to do it in manually every step +defaults: + run: + shell: bash -leo pipefail {0} + +env: + cache_key: gcc2 # The number (#) following the cache_key "gcc" is to flush Action cache. + CC: gcc-10 + FC: gfortran-10 + CXX: g++-10 + +# A note on flushing Action cache and relevance to "cache_key" above. +# There is no way to flush the Action cache, and hence a number (#) is appended +# to the "cache_key" (gcc). +# If the dependencies change, increment this number and a new cache will be +# generated by the dependency build step "setup" +# There is a Github issue to force clear the cache. +# See discussion on: +# https://stackoverflow.com/questions/63521430/clear-cache-in-github-actions + +# The jobs are split into: +# 1. a dependency build step (setup), and +# 2. a UPP build step (build) +# The setup is run once and the environment is cached, +# so each build of UPP can reuse the cached dependencies to save time (and compute). + +jobs: + setup: + runs-on: ubuntu-latest + + steps: + # Cache spack, compiler and dependencies + - name: cache-env + id: cache-env + uses: actions/cache@v2 + with: + path: | + spack + ~/.spack + key: spack-${{ runner.os }}-${{ env.cache_key }} + + - name: checkout-upp # This is for getting spack.yaml + if: steps.cache-env.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + path: UPP + + # Install dependencies using Spack + - name: install-dependencies-with-spack + if: steps.cache-env.outputs.cache-hit != 'true' + run: | + git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git + source spack/share/spack/setup-env.sh + spack env create upp-env UPP/ci/spack.yaml + spack env activate upp-env + spack compiler find + spack external find + spack add mpich@3.4.2 + spack concretize + spack install --dirty -v + + build: + needs: setup + runs-on: ubuntu-latest + + steps: + - name: checkout-upp + uses: actions/checkout@v2 + with: + path: UPP + + - name: cache-env + id: cache-env + uses: actions/cache@v2 + with: + path: | + spack + ~/.spack + key: spack-${{ runner.os }}-${{ env.cache_key }} + + - name: build-upp + run: | + source spack/share/spack/setup-env.sh + spack env activate upp-env + export CC=mpicc + export FC=mpif90 + cd UPP + mkdir -p build && cd build + cmake -DCMAKE_INSTALL_PREFIX=../install .. + make -j2 VERBOSE=1 + make install diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml new file mode 100644 index 000000000..97ab17caa --- /dev/null +++ b/.github/workflows/intel.yml @@ -0,0 +1,114 @@ +name: Intel Linux Build +on: [push, pull_request, workflow_dispatch] + +# Use custom shell with -l so .bash_profile is sourced which loads intel/oneapi/setvars.sh +# without having to do it in manually every step +defaults: + run: + shell: bash -leo pipefail {0} + +# Set I_MPI_CC/F90 so Intel MPI wrapper uses icc/ifort instead of gcc/gfortran +env: + cache_key: intel2 # The number (#) following the cache_key "intel" is to flush Action cache. + CC: icc + FC: ifort + CXX: icpc + I_MPI_CC: icc + I_MPI_F90: ifort + +# A note on flushing Action cache and relevance to "cache_key" above. +# There is no way to flush the Action cache, and hence a number (#) is appended +# to the "cache_key" (intel). +# If the dependencies change, increment this number and a new cache will be +# generated by the dependency build step "setup" +# There is a Github issue to force clear the cache. +# See discussion on: +# https://stackoverflow.com/questions/63521430/clear-cache-in-github-actions + +# The jobs are split into: +# 1. a dependency build step (setup), and +# 2. a UPP build step (build) +# The setup is run once and the environment is cached, +# so each build of UPP can reuse the cached dependencies to save time (and compute). + +jobs: + setup: + runs-on: ubuntu-latest + + steps: + # Cache spack, compiler and dependencies + - name: cache-env + id: cache-env + uses: actions/cache@v2 + with: + path: | + spack + ~/.spack + /opt/intel + key: spack-${{ runner.os }}-${{ env.cache_key }} + + - name: install-intel-compilers + if: steps.cache-env.outputs.cache-hit != 'true' + run: | + wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB + sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB + echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + sudo apt-get update + sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic + echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile + + - name: checkout-upp # This is for getting spack.yaml + if: steps.cache-env.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + path: UPP + + # Install dependencies using Spack + - name: install-dependencies-with-spack + if: steps.cache-env.outputs.cache-hit != 'true' + run: | + git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git + source spack/share/spack/setup-env.sh + spack env create upp-env UPP/ci/spack.yaml + spack env activate upp-env + spack compiler find + spack external find + spack add intel-oneapi-mpi + spack concretize + spack install --dirty -v + + build: + needs: setup + runs-on: ubuntu-latest + + steps: + - name: checkout-upp + uses: actions/checkout@v2 + with: + path: UPP + + - name: install-intel + run: | + echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile + + - name: cache-env + id: cache-env + uses: actions/cache@v2 + with: + path: | + spack + ~/.spack + /opt/intel + key: spack-${{ runner.os }}-${{ env.cache_key }} + + - name: build-upp + run: | + source spack/share/spack/setup-env.sh + spack env activate upp-env + export CC=mpiicc + export FC=mpiifort + cd UPP + mkdir -p build && cd build + cmake -DCMAKE_INSTALL_PREFIX=../install .. + make -j2 VERBOSE=1 + make install diff --git a/.gitignore b/.gitignore index 2dc827ccf..c9d3f6e12 100644 --- a/.gitignore +++ b/.gitignore @@ -9,8 +9,8 @@ # USE CAUTION WHEN ADDING WILDCARDS, as some builds use different filename # # conventions than others # ############################################################################## -build/ -install/ +build*/ +install*/ *.[aox] *.mod diff --git a/.gitmodules b/.gitmodules index e69de29bb..742a824df 100644 --- a/.gitmodules +++ b/.gitmodules @@ -0,0 +1,4 @@ +[submodule "post_gtg.fd"] + path = sorc/ncep_post.fd/post_gtg.fd + url = https://github.com/NCAR/UPP_GTG + update = none diff --git a/CMakeLists.txt b/CMakeLists.txt index ff311e9d0..483d8defd 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -15,6 +15,7 @@ list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") option(OPENMP "use OpenMP threading" ON) option(BUILD_POSTEXEC "Build NCEPpost executable" ON) option(BUILD_WITH_WRFIO "Build NCEPpost with WRF-IO library" OFF) +option(BUILD_WITH_GTG "Build NCEPpost with NCAR/GTG" OFF) option(ENABLE_DOCS "Enable generation of doxygen-based documentation." OFF) if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") @@ -47,14 +48,16 @@ find_package(bacio REQUIRED) find_package(crtm REQUIRED) find_package(g2 REQUIRED) find_package(g2tmpl REQUIRED) -find_package(ip REQUIRED) +if(BUILD_WITH_GTG) + find_package(ip REQUIRED) +endif() if(BUILD_POSTEXEC) find_package(nemsio REQUIRED) find_package(sfcio REQUIRED) find_package(sigio REQUIRED) find_package(sp REQUIRED) - find_package(w3nco REQUIRED) + find_package(w3emc REQUIRED) if(BUILD_WITH_WRFIO) find_package(wrf_io REQUIRED) endif() diff --git a/Externals.cfg b/Externals.cfg deleted file mode 100644 index 4fa904f9c..000000000 --- a/Externals.cfg +++ /dev/null @@ -1,9 +0,0 @@ -[gtg] -tag = ncep_post_gtg.v2.0.3 -protocol = git -repo_url = git@github.com:NCAR/UPP_GTG.git -local_path = sorc/post_gtg.fd -required = True - -[externals_description] -schema_version = 1.0.0 diff --git a/README.md b/README.md index 6f80fd158..1592d58d4 100644 --- a/README.md +++ b/README.md @@ -8,9 +8,11 @@ output. The UPP is currently used in operations with the Global Forecast System (GFS), GFS Ensemble Forecast System (GEFS), North American Mesoscale (NAM), Rapid Refresh (RAP), High Resolution Rapid Refresh -(HRRR), Short Range Ensemble Forecast (SREF), Hurricane WRF (HWRF) -applications, and is also used in Unified Forecasting System (UFS) -applications. +(HRRR), Short Range Ensemble Forecast (SREF), and Hurricane WRF (HWRF) +applications. It is also used in the Unified Forecasting System (UFS), +including the Rapid Refresh Forecast System (RRFS), Hurricane Application +Forecasting System (HAFS), and the Medium Range Weather (MRW) and Short +Range Weather (SRW) Applications. The UPP provides the capability to compute a variety of diagnostic fields and interpolate to pressure levels or other vertical @@ -41,23 +43,29 @@ Examples of UPP products include: - Radar reflectivity products - Satellite look-alike products -Support for the UFS UPP is provided through the UFS Forum by the -Developmental Testbed Center (DTC) for FV3-based applications. -For full documentation see https://noaa-emc.github.io/UPP/. +## User Support +Support for the UFS UPP is provided through the [UFS Forum](https://forums.ufscommunity.org/) +by the Developmental Testbed Center (DTC). -The UPP uses some of the [NCEPLIBS](https://github.com/NOAA-EMC/NCEPLIBS) -project. +## Documentation +User Guide for latest public release: https://upp.readthedocs.io/en/latest/. + +Technical code-level documentation: https://noaa-emc.github.io/UPP/. + +## Developer Information +Please see review the [wiki](https://github.com/NOAA-EMC/UPP/wiki) ## Authors NCEP/EMC Developers -Code Manager: Wen Meng, Huiya Chuang, Kate Fossell +Code Managers: Wen Meng, Huiya Chuang, Kate Fossell ## Prerequisites -This package requires the following NCEPLIBS packages: +The UPP requires certain NCEPLIB packages to be installed via +the HPC-Stack project. - [NCEPLIBS-g2](https://github.com/NOAA-EMC/NCEPLIBS-g2) - [NCEPLIBS-g2tmpl](https://github.com/NOAA-EMC/NCEPLIBS-g2tmpl) @@ -71,9 +79,9 @@ This package requires the following NCEPLIBS packages: Also required to build NCEPpost executable (cmake option BUILD_POSTEXEC): -- [NCEPLIBS-sigio](https://github.com/NOAA-EMC/NCEPLIBS-sigio) - -- [NCEPLIBS-sfcio](https://github.com/NOAA-EMC/NCEPLIBS-sfcio) - -- [NCEPLIBS-nemsio](https://github.com/NOAA-EMC/NCEPLIBS-nemsio) - +- [NCEPLIBS-sigio](https://github.com/NOAA-EMC/NCEPLIBS-sigio) +- [NCEPLIBS-sfcio](https://github.com/NOAA-EMC/NCEPLIBS-sfcio) +- [NCEPLIBS-nemsio](https://github.com/NOAA-EMC/NCEPLIBS-nemsio) - [NCEPLIBS-gfsio](https://github.com/NOAA-EMC/NCEPLIBS-gfsio) The [NCEPLIBS-wrf_io](https://github.com/NOAA-EMC/NCEPLIBS-wrf_io) @@ -92,29 +100,18 @@ The following third-party libraries are required: Builds include: -- Operational use GNC build as Wen described for both library and - executable (library used for GFS only at this time) - -- MRW App uses UPP packaged with nceplibs and cmake to build/run with - executable (via release/public-v1 branch). - -- SRW App uses UPP repo branch/tag directly and uses cmake to - build/run with executable (via release/public-v2 branch). - -- Community standalone uses UPP repo branch/tag directly and uses - cmake to build/run with executable (via release/public-v2 - branch). For these procedures, we add a - -DCMAKE_PREFIX_PATH=${INSTALL_PREFIX} where INSTALL_PREFIX is the - location of the nceplibs installation as a dependency requirement. - -``` -mkdir build -cd build -cmake .. -DCMAKE_INSTALL_PREFIX=/path/to/install -make -make test -make install -``` +- Inline post (UPP library): Currently only supported for the GFS, RRFS, + HAFS, and the UFS-MRW Application. + +- Offline post (UPP executable): Supported for Regional applications + including SRW, RRFS, HAFS, and standalone applications of UPP. + + +CMake is used to manage all builds of the UPP. +The script `UPP/tests/compile_upp.sh` can be used to automatically +build UPP on fully supported platforms where HPC-stack is supported. +Details in this script can be used to build on new platforms. + ## Disclaimer diff --git a/VERSION b/VERSION index 89acc9519..275283a18 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -10.0.11 +11.0.0 diff --git a/ci/spack.yaml b/ci/spack.yaml new file mode 100644 index 000000000..1c7aa122e --- /dev/null +++ b/ci/spack.yaml @@ -0,0 +1,23 @@ +# Spack environment file to build UPP dependencies +spack: + packages: + all: + compiler: [intel, gcc] + specs: + - netcdf-c@4.7.4 + - netcdf-fortran@4.5.3 + - bacio@2.4.1 + - w3emc@2.9.2 + - g2@3.4.5 + - g2tmpl@1.10.0 + - sp@2.3.3 + - ip@3.3.3 + - sigio@2.3.2 + - sfcio@1.4.1 + - nemsio@2.5.4 + - wrf-io@1.2.0 + - crtm@2.3.0 + view: true + concretizer: + unify: true + diff --git a/cmake/PackageConfig.cmake.in b/cmake/PackageConfig.cmake.in index acaf390bf..88f9902d7 100644 --- a/cmake/PackageConfig.cmake.in +++ b/cmake/PackageConfig.cmake.in @@ -30,7 +30,7 @@ find_dependency(ip CONFIG) #find_dependency(sfcio CONFIG) #find_dependency(sigio CONFIG) #find_dependency(sp CONFIG) -#find_dependency(w3nco CONFIG) +#find_dependency(w3emc CONFIG) # Get the build type from library target get_target_property(@PROJECT_NAME@_BUILD_TYPES @PROJECT_NAME@::@PROJECT_NAME@ IMPORTED_CONFIGURATIONS) diff --git a/docs/2D-decomp.md b/docs/2D-decomp.md new file mode 100644 index 000000000..105a28cf0 --- /dev/null +++ b/docs/2D-decomp.md @@ -0,0 +1,21 @@ +# 2-D Decomposition Overview + +**Author:** George Vandenberghe + +**Date:** June 2022 + +## Comparison of 1D vs. 2D Decomposition +The 1D decomposition can read state from a model forecast file, either by reading on rank 0 and scattering, or by doing MPI_IO on the model history file using either nemsio, sigio, or netcdf serial or parallel I/O. Very old post tags also implement the more primitive full state broadcast or (a performance bug rectified 10/17) read the entire state on all tasks. This is mentioned in case a very old tag is encountered. + +The 2D decomposition only supports MPI_IO, namely NetCDF Parallel I/O. But the code is backwards compatible and all I/O methods remain supported for the 1D decomposition cases and works for all cases currently supported by older 1D tags and branches. + +## 2D Decomposition Design + +The 2D decomposition operates on subdomains with some latitudes and some longitudes. The subdomains are lon-lat rectangles rather than strips. This means state must be chopped into pieces in any scatter operation and the pieces reassembled in any gather operation that requires a continuous in memory state. I/O and halo exchanges both require significantly more bookkeeping. + +The structural changes needed for the 2D decomposition are implemented in MPI_FIRST.f and CTLBLK.f. The CTLBLK.f routine contains numerous additional variables describing left and right domain boundaries. Many additional changes are also implemented in EXCH.f to support 2D halos. Many additional routines required addition of the longitude subdomain limits but changes to the layouts are handled in CTLBLK.f and the "many additional routines" do not require additional changes when subdomain shapes are changed and have not been a trouble point. + +Both MPI_FIRST.f and EXCH.f contain significant additional test code to exchange arrays containing grid coordinates and ensure EXACT matches for all exchanges before the domain exchanges are performed. This is intended to trap errors in the larger variety of 2D decomposition layouts that are possible and most of it can eventually be removed or made conditional at build and run time. + +Indices and variables to facilitate the 2D decomposition are found in CTLBLK.f and shared in the rest of UPP through use of CTLBLK.mod. + diff --git a/docs/Acknowledgments.rst b/docs/Acknowledgments.rst index ec69df3a3..f5aa9c98d 100644 --- a/docs/Acknowledgments.rst +++ b/docs/Acknowledgments.rst @@ -18,4 +18,4 @@ acknowledge the Developmental Testbed Center UPP Team. For referencing this document please use: -UPP Users Guide V9.0.0, 24 pp. +UPP Users Guide V10.1.0, 24 pp. diff --git a/docs/AddNewVariable.rst b/docs/AddNewVariable.rst index 7fd5ff268..a502d4b9c 100644 --- a/docs/AddNewVariable.rst +++ b/docs/AddNewVariable.rst @@ -79,41 +79,32 @@ with examples in the sections below. This flat file (instead of the xml file) is read in by UPP as it was much faster to read a text file than an xml file. -2. Define the new field: RQSTFLD.F - - This file contains a list of all possible fields to be output by UPP, corresponding Grib1 key-word character - strings, UPP ID (Index) for internal code, and Grib1 IDs. Note that as of December 2020, EMC removed the Grib1 - option from its repository as part of its re-reginnering effort. Users will continue to use UPP ID (Index) for - defining the new variable to be added. However, the character string and Grib1 ID in RQSTFLD.F will no longer - be used by UPP. - -3. Allocate the field: ALLOCATE.f +2. Allocate the field: ALLOCATE.f This file is the instantiation or allocation of the variable. Note that the variables are defined based on the parallel processing capability of UPP - use an example from the file. -4. Deallocate the field: DEALLOCATE.f +3. Deallocate the field: DEALLOCATE.f All good programmers give back their resources when they are done. Please update this routine to return your resource to the system. -5. Declare the new variable: VRBLS2D_mod.f, VRBLS3D_mod.f, or VRBLS4D_mod.f +4. Declare the new variable: VRBLS2D_mod.f, VRBLS3D_mod.f, or VRBLS4D_mod.f The variable is declared in one of these modules defining files depending on its dimension. -6. Read model output if necessary: INITPOST_GFS_NETCDF_PARA.f (current operational netcdf output with GFS V16), - INITPOST_NETCDF.f (LAM FV3 netcdf) +5. Read model output if necessary: INITPOST_NETCDF.f Check first to see if all variables needed to derive your new variable are already available in UPP. If not, you will need to use one of these files for reading the model output files. The appropriate one will need to be chosen based on the model and model output format. -7. Add to appropriate routine for filling the new variable: e.g. SURFCE.f, MDLFLD.f, MDL2P.f, etc +6. Add to appropriate routine for filling the new variable: e.g. SURFCE.f, MDLFLD.f, MDL2P.f, etc This is the place where you will derive your new variable and then fill the Grib2 array with the data to be written out later on. -8. Build or rebuild the code for changes to take effect before running your UPP run script. +7. Build or rebuild the code for changes to take effect before running your UPP run script. **Example Procedure: Steps for adding a new variable ‘TG3’** @@ -180,7 +171,7 @@ with examples in the sections below. e) Add the new variable to the UPP/parm/post_avblflds.xml, which lists all fields available for output in GRIB2 format. This file is generally not modified unless adding a new field or modifying an existing one. - - Post_avblfldidx: the unique array number given in the RQSTFLD.f routine. + - Post_avblfldidx: the unique array index number used to store this variable. - Shortname: name describing the variable and level type - Pname: the abbreviation for your variable (should match what is used in params_grib2_tbl_new) - Table info: table used if not standard WMO @@ -229,49 +220,7 @@ with examples in the sections below. This flat file (instead of the xml file) is read in by UPP as it was much faster to read a text file than an xml file. -2. Define the new variable in RQSTFLD.F which includes a list of all possible fields to be output by - UPP, corresponding Grib1 key-word character strings, UPP ID (Index) for internal code, and Grib1 IDs. - Ensure your code is up-to-date and pick a unique identifier that is not already used for the new variable. - Currently, the 900's are being used for new contributions. - - Example Entry - - | ! HWRF addition for v_flux as pass through variable: - - | DATA IFILV(901),AVBL(901),IQ(901),IS(901),AVBLGRB2(901) & - | & /1,'MODEL SFC V WIND STR’,125,001, & - | & 'V_FLX ON surface’/ - - Where: - - **IFILV** Identifies field as MASS/VELOCITY point (e.g. 1) - - **AVBL** is the model output character string variable name for Grib1 (e.g. MODEL SFC V WIND STR) - - **IQ** is the GRIB PDS OCTET 9 (table 2) - Indicator of parameter and units (e.g. 125) - - **IS** is the GRIB PDS OCTET 10 (table 3&3a) - Indicator of type of level or layer (e.g. 001) - - **AVBLGRB2** is the model output character string variable name for Grib2 (e.g. V_FLX ON surface) - - A UNIQUE array Index UPP uses to store this variable in parallel arrays (e.g. **901**) - - User procedure - - Soil temperature (TSOIL) is found in the Grib1 parameter tables as parameter number 085, so this - can be used for the Grib1 ID. - http://www.nco.ncep.noaa.gov/pmb/docs/on388/table2.html - - Use level type 'depth below land surface', which is 111. - http://www.nco.ncep.noaa.gov/pmb/docs/on388/table3.html - - New variables are continuously being added to UPP, so be sure to check that the UPP Index 999 is - still available before using it to add your new variable. If it is already in use, pick the next - available Index. - - Add as: - - :: - - DATA IFILV(999),AVBL(999),IQ(999),IS(999),AVBLGRB2(999) & - & /1,'DEEP SOIL TMP',085,111, & - & 'DEEP TSOIL ON depth_bel_land_sfc'/ - - .. note:: - Since Grib1 is no longer supported, the variable character strings and Grib IDs for Grib1 are not - important, but still need to be included here for correct formatting. - -3. Allocate the new variable in ALLOCATE_ALL.f +2. Allocate the new variable in ALLOCATE_ALL.f This file is the instantiation or allocation of the variable. Note that the variables are defined based on the parallel processing capability of UPP - use an example from the file. @@ -282,7 +231,7 @@ with examples in the sections below. allocate(tg3(im,jsta_2l:jend_2u)) -4. De-allocate the variable to give the resources back in DEALLOCATE.f +3. De-allocate the variable to give the resources back in DEALLOCATE.f All good programmers give back their resources when they are done. Please update this routine to return your resources to the system. @@ -293,7 +242,7 @@ with examples in the sections below. deallocate(tg3) -5. Declare the new variable in the appropriate file depending on its dimensions; +4. Declare the new variable in the appropriate file depending on its dimensions; VRBLS2D_mod.f, VRBLS3D_mod.f or VRBLS4D_mod.f User procedure @@ -304,8 +253,8 @@ with examples in the sections below. tg3(:,:) -6. Read the field from the GFS model output file by adding the new variable into INITPOST_GFS_NETCDF_PARA.f. - This file is used for reading the GFS model FV3 output files in netcdf format. +5. Read the field from the GFS model output file by adding the new variable into INITPOST_NETCDF.f. + This file is used for reading the GFS model FV3 output files in parallel netcdf format. User procedure - Add to top section of the routine in ‘use vrbls2d’ to initiate the new variable as: @@ -324,7 +273,7 @@ with examples in the sections below. call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & spval,VarName,tg3) -7. Determine the appropriate routine to add the new variable to (e.g. SURFCE.f, MDLFLD.f, +6. Determine the appropriate routine to add the new variable to (e.g. SURFCE.f, MDLFLD.f, MDL2P.f, etc). This is the place that you will fill the Grib2 array with the data to be written out later on. The appropriate routine will depend on what your field is. For example, if you have a new diagnostic called foo, and you want it interpolated to pressure levels, you would need to add it to MDL2P.f. If foo was only a @@ -365,14 +314,14 @@ with examples in the sections below. endiF ENDIF -8. Build or rebuild the code for changes to take effect before running your UPP run script. +7. Build or rebuild the code for changes to take effect before running your UPP run script. - User procedure IF you already have the code built. Otherwise, see the User's Guide for instructions on building. + User procedure for building on pre-configured machines. Otherwise, see the User's Guide for instructions on building. :: - >> cd UPP/build - >> make install + >> cd UPP/tests + >> ./compile_upp.sh Assuming the modified code built successfully and you were able to produce Grib2 output, you can check the Grib2 file for your new variable. @@ -393,4 +342,3 @@ with examples in the sections below. number of latitudes between pole-equator=96 #points=73728 lat 89.284225 to -89.284225 lon 0.000000 to 359.062500 by 0.937500 - diff --git a/docs/CodeOverview.rst b/docs/CodeOverview.rst index 5ca2284ce..b06efdb08 100644 --- a/docs/CodeOverview.rst +++ b/docs/CodeOverview.rst @@ -2,19 +2,32 @@ Code Overview ************* -The UPP can be used to post-process WRF-ARW, WRF-NMM, NMMB, GFS, CFS, and FV3 forecasts with current -support within UFS applications available for FV3 only. It can ingest FV3 write component files in -netCDF and binarynemsiompiio format. +The UPP is used to post-process model forecasts and provides the capability to compute a variety of +diagnostic fields and interpolate to pressure levels or other vertical coordinates. -UPP Functionalities: +The UPP also incorporates the Joint Center for Satellite Data Assimilation (JCSDA) Community Radiative +Transfer Model (CRTM) to compute model derived brightness temperature (TB) for various instruments and +channels. This additional feature enables the generation of a number of simulated satellite products +including GOES products. - - Interpolates the forecasts from the models native vertical coordinate to NWS standard output - levels (e.g., pressure, height) and computes mean sea level pressure. If the requested parameter - is on a models native level, then no vertical interpolation is performed. +Output from the UPP is in National Weather Service (NWS) and World Meteorological Organization (WMO) +`GRIB2 `_ format and can be used directly by +visualization, plotting, or verification packages, or for further downstream post-processing, e.g. +statistical post-processing techniques. - - Computes diagnostic output quantities (e.g., convective available potential energy, helicity, - relative humidity). A full list of fields that can be generated by the UPP is provided in - :doc:`UPP_GRIB2_Table`. +Examples of UPP products include: - - Outputs the results in NWS and WMO standard GRIB2 format (see - `Grib documentation `_). +- T, Z, humidity, wind, cloud water, cloud ice, rain, and snow on pressure levels +- SLP, shelter level T, humidity, and wind fields +- Precipitation-related fields +- PBL-related fields +- Severe weather products (e.g. CAPE, Vorticity, Wind shear) +- Radiative/Surface fluxes +- Cloud related fields +- Aviation products +- Radar reflectivity products +- Satellite look-alike products + +A full list of fields that can be generated by the UPP is provided in :doc:`UPP_GRIB2_Table`. + +Support for the community UPP is provided through the `UFS Forum `_. diff --git a/docs/Doxyfile.in b/docs/Doxyfile.in index 85459abdc..f46163210 100644 --- a/docs/Doxyfile.in +++ b/docs/Doxyfile.in @@ -855,6 +855,7 @@ WARN_LOGFILE = # Note: If this tag is empty the current directory is searched. INPUT = @abs_top_srcdir@/docs/user_guide.md \ + = @abs_top_srcdir@/docs/2D-decomp.md \ @abs_top_srcdir@/sorc/ncep_post.fd \ @config_srcdir@ diff --git a/docs/InputsOutputs.rst b/docs/InputsOutputs.rst index 56c65cb9b..ebc1626fc 100644 --- a/docs/InputsOutputs.rst +++ b/docs/InputsOutputs.rst @@ -14,22 +14,37 @@ Input files =========== The UPP requires the following input files: - - The itag namelist + - The model forecast file + - The itag namelist file - The GRIB2 control file - Additional data files (e.g. lookup tables, coefficient files for satellite) +-------------- +Model Forecast +-------------- + +The UPP ingests FV3 write component files in parallel netCDF format. + +The table below is a list of the unified model variables available from the FV3 model core. Whether a +specific variable is able to be read by UPP relies on dependencies such as physics options and model. +This table does not include variables that are diagnosed when running the UPP. + +UFS Unified Model Variables + - :doc:`UFS_unified_variables_table` + ---- ITAG ---- -The :bolditalic:`itag` namelist that is read in by the :bolditalic:`upp.x` executable from stdin (unit 5) is +The file called :bolditalic:`itag` is a text file that contains the fortran namelist &model_inputs. It is +read in by the :bolditalic:`upp.x` executable from stdin (unit 5) and is generated automatically within the UFS application workflow or stand-alone run script based on user-defined options. It should not be necessary to edit this. For description purposes, the namelist -(:bolditalic:`itag`) contains 7 lines for FV3: +&model_inputs (:bolditalic:`itag` file) contains 7 lines for FV3: -#. Name of the FV3 (pressure level) output file to be posted. +#. Name of the FV3 (pressure level) output file to be post-processed. -#. Format of FV3 model output (netcdf, binarynemsiompiio). +#. Format of FV3 model output (netcdfpara). #. Format of UPP output (GRIB2) @@ -53,22 +68,12 @@ which fields and levels to process. A default control file, :bolditalic:`postxconfig-NT.txt`, is provided and read by the UPP. For users wishing to customize the control file to add or remove fields and/or levels, they may do so by modifying the :bolditalic:`postcntrl.xml` and then remaking the text file as described in the later section -:ref:`Creating the Flat Text File`. +:ref:`create_txt_file`. .. Note:: The control file names :bolditalic:`postxconfig-NT.txt` and :bolditalic:`postcntrl.xml` are generic - names and are different depending on the application used. - -The tables below list all fields that are included in the control files for the various UFS -applications. All fields in the tables may not be present in your output depending on whether the field -dependencies are available in your model output. - -UFS MRW Table (GFS model) - - :doc:`MRW_GFSPRS_table` - -UFS SRW Tables (LAM - Limited Area Model) - - :doc:`SRW_BGDAWP_table` - - :doc:`SRW_BGRD3D_table` + names and are different depending on the application used. Control files for various operational + models are located in the :bolditalic:`UPP/parm` directory. Controlling which variables the UPP outputs ------------------------------------------- @@ -107,9 +112,11 @@ levels are currently available for output: - For PBL layer averages, the levels correspond to 6 layers with a thickness of 30 hPa each. - For flight level, the levels are 30 m, 50 m, 80 m, 100 m, 305 m, 457 m, 610 m, 914 m, 1524 m, 1829 m, 2134 m, 2743 m, 3658 m, 4572 m, 6000 m, 7010 m. -- For AGL radar reflectivity, the levels are 4000 and 1000 m (see Appendix A for details). +- For AGL radar reflectivity, the levels are 4000 and 1000 m. - For surface or shelter-level output, the is not necessary. +.. _create_txt_file: + Creating the Flat Text File --------------------------- @@ -130,14 +137,15 @@ run-time failures with UPP. To run the validation: xmllint --noout --schema EMC_POST_CTRL_Schema.xsd postcntrl.xml xmllint --noout --schema EMC_POST_Avblflds_Schema.xsd post_avblflds.xml -Once the xmls are validated, the user will need to generate the flat file. The makefile will call the -perl program :bolditalic:`parm/POSTXMLPreprocessor.pl` to regenerate any post flat files -:bolditalic:`postxconfig-NT.txt` where modifications were made since it was last run. Generate the flat +Once the xmls are validated, the user will need to generate the flat file. The below command will run the +perl program :bolditalic:`parm/POSTXMLPreprocessor.pl` to generate the post flat file. Generate the flat file: .. code-block:: console - make + /usr/bin/perl POSTXMLPreprocessor.pl your_user_defined_xml post_avblflds.xml your_user_defined_flat + +where *your_user_defined_xml* is your modified xml and *your_user_defined_flat* is the output text file. ============ Output Files diff --git a/docs/Installation.rst b/docs/Installation.rst index 76c76fc8d..8dbf731b6 100644 --- a/docs/Installation.rst +++ b/docs/Installation.rst @@ -7,47 +7,40 @@ Building Stand-Alone ******************** +The UPP uses a CMake-based build system to integrate all the required components for building the UPP. +Once built, the UPP can be run stand-alone (outside the UFS Applications) to post-process model output. + ===================== Software Requirements ===================== -Before installing the UPP code, it is necessary to ensure that you have the required libraries -available on your system. These libraries include: - - - The external NCEP libraries - https://github.com/NOAA-EMC/NCEPLIBS-external - - - The NCEP libraries - https://github.com/NOAA-EMC/NCEPLIBS - -An introduction of each can be found in their respective top level :bolditalic:`README.md` files. -Detailed instructions for building the libraries on various platforms can be found in the -**NCEPLIBS-external/doc** directory. +The UPP is tested on a variety of research platforms, including NOAA HPC systems (e.g. Hera, Orion) and +the NCAR HPC Cheyenne. These supported platforms are pre-configured for building and running the UPP and already +have the required libraries available via `HPC-Stack `_ in a centralized +location. The HPC-Stack is a script-based build system that builds the software stack required by UFS components. -Certain machines do have the NCEP libraries in a pre-installed location for use to build UPP. Paths to -these pre-installed libraries are available on the -`UFS-SRW wiki `_ -and include platform name and compiler version. +Users working on unsupported platforms will need to install the HPC-Stack on their system and can do so following +the instructions in the `HPC-Stack User's Guide `_. ============================ Obtaining and Installing UPP ============================ -Building and running UPP V9.0.0 has been tested on the following platforms using pre-configured libraries. +Building and running UPP V10.1.0 has been tested and is supported on the following pre-configured platforms. +---------------+----------------------+ | System | Compiler and Version | +===============+======================+ -| NCAR Cheyenne | Intel 19.1.1 | +| NCAR Cheyenne | Intel 2021.2 | | +----------------------+ -| | GNU 9.1.0 | | | GNU 10.1.0 | +---------------+----------------------+ | NOAA Hera | Intel 18.0.5.274 | +---------------+----------------------+ +| NOAA Orion | Intel 2018.4 | ++---------------+----------------------+ -Move to the directory where you want to clone and build UPP and clone the repository into the directory -UPP. +Move to the directory where you want to install UPP and clone the repository. .. code-block:: console @@ -55,41 +48,37 @@ UPP. where, ``branch-or-tag-name`` is the release branch or tag you wish to clone. -Move into the top level UPP directory and create and move into the build directory. Then build the UPP code -using the cmake utility. -The path ``INSTALL_PREFIX`` should point to the location of the pre-installed NCEP libraries. +Move to the directory with the build script and build the UPP. .. code-block:: console - cd UPP - mkdir build && cd build + cd UPP/tests - cmake .. -DCMAKE_INSTALL_PREFIX=.. -DCMAKE_PREFIX_PATH=${INSTALL_PREFIX} - make install + ./compile_upp.sh .. note:: - To build in debug mode, you can add :bolditalic:`-DCMAKE_BUILD_TYPE=Debug` to the cmake command. + To build in debug mode, you can add :bolditalic:`-DCMAKE_BUILD_TYPE=Debug` to the *cmake_opts* + parameter in the :bolditalic:`compile_upp.sh` script. This removes compiler optimization flags and adds -g to the fortran compilation. You can also use :bolditalic:`-DCMAKE_BUILD_TYPE=RELWITHDEBINFO`, which gives the -g, but keeps the -O2 optimization for the fortran compilation. Move back to the top level UPP directory and create a directory for the CRTM fix files to be unpacked in. Download the fix files from the Github `release page -`_ or use the wget command. Unpack the +`_ or use the wget command. Unpack the tar file. .. code-block:: console cd ../ mkdir crtm && cd crtm - wget https://github.com/NOAA-EMC/UPP/releases/download/upp_v9.0.0/fix.tar.gz + wget https://github.com/NOAA-EMC/UPP/releases/download/upp_v10.1.0/fix.tar.gz tar -xzf fix.tar.gz .. note:: - To make a clean build, simply remove both the **/build** directory and the - :bolditalic:`bin/upp.x` executable and then re-create the build from step #2. This is recommended if a - mistake is made during the installation process. If a simple change is made to the code, you can simply - type :bolditalic:`make install` again in the pre-existing build directory. + To make a clean build, simply remove both the **tests/build** and **tests/install** directories and the + :bolditalic:`exec/upp.x` executable and then rerun the :bolditalic:`compile_upp.sh script. This is + recommended if a mistake is made during the installation process. ======================= UPP Directory Structure @@ -98,13 +87,10 @@ UPP Directory Structure Under the main directory **UPP** reside the following relevant subdirectories (The * indicates a directory that exists only after the build is complete): - | **bin***: Contains the :bolditalic:`upp.x` executable after successful compilation - - | **build**: Contains the UPP build + | **exec***: Contains the :bolditalic:`upp.x` executable after successful compilation - | **include***: Contains include modules built/used during compilation of UPP - - | **lib***: Libraries built/used by UPP that are separate from NCEPlibs + | **modulefiles**: Contains modulefiles for specific platforms and compilers for building on + pre-configured machines. | **parm**: Contains parameter files, which can be modified by the user to control how the post processing is performed. @@ -114,3 +100,7 @@ directory that exists only after the build is complete): | **sorc**: Contains source codes for: | - **ncep_post.fd**: Source code for the UPP + + | **tests**: Contains the scripts used to install UPP + | - **build***: Contains the UPP build + | - **install***: Contains the installed executable (bin/upp.x), modules, and libraries diff --git a/docs/Introduction.rst b/docs/Introduction.rst index 4dc972b54..f5646c1b1 100644 --- a/docs/Introduction.rst +++ b/docs/Introduction.rst @@ -2,32 +2,16 @@ Introduction ************ -The Unified Post Processor (UPP) software package is a software package designed to generate useful -products from raw model output. The UPP is currently used in operations with the Global Forecast -System (GFS), GFS Ensemble Forecast System (GEFS), North American Mesoscale (NAM), Rapid Refresh (RAP), -High Resolution Rapid Refresh (HRRR), Short Range Ensemble Forecast (SREF), Hurricane WRF (HWRF) -applications, and is also used in Unified Forecasting System (UFS) applications. The UPP provides the -capability to compute a variety of diagnostic fields and interpolate to pressure levels or other -vertical coordinates. UPP also incorporates the Joint Center for Satellite Data Assimilation (JCSDA) -Community Radiative Transfer Model (CRTM) to compute model derived brightness temperature (TB) for -various instruments and channels. This additional feature enables the generation of a number of -simulated satellite products including GOES products. Output from the UPP is in National Weather -Service (NWS) and World Meteorological Organization (WMO) GRIB2 format and can be used directly by -visualization, plotting, or verification packages, or for further downstream post-processing, e.g. -statistical post-processing techniques. +The Unified Post Processor (UPP) is a software package designed to generate useful +products from raw model output. -Examples of UPP products include: +The UPP is currently used in operations with the Global Forecast System (GFS), GFS Ensemble Forecast +System (GEFS), North American Mesoscale (NAM), Rapid Refresh (RAP), High Resolution Rapid Refresh +(HRRR), Short Range Ensemble Forecast (SREF), and Hurricane WRF (HWRF) applications. It is also used +in the Unified Forecasting System (UFS), including the Rapid Refresh Forecast System (RRFS), Hurricane +Application Forecasting System (HAFS), and the Medium Range Weather (MRW) and Short Range Weather (SRW) +Applications. -- T, Z, humidity, wind, cloud water, cloud ice, rain, and snow on pressure levels -- SLP, shelter level T, humidity, and wind fields -- Precipitation-related fields -- PBL-related fields -- Severe weather products (e.g. CAPE, Vorticity, Wind shear) -- Radiative/Surface fluxes -- Cloud related fields -- Aviation products -- Radar reflectivity products -- Satellite look-alike products - -Support for the UFS UPP is provided through the UFS Forum by the Developmental Testbed Center (DTC) for -FV3-based applications. +This software package can be run inline, built as a library to be used by the model, and offline, +built stand-alone and run separate from the model. This documentation largely details the offline +procedures. diff --git a/docs/MRW_GFSPRS_table.csv b/docs/MRW_GFSPRS_table.csv deleted file mode 100644 index db595d16d..000000000 --- a/docs/MRW_GFSPRS_table.csv +++ /dev/null @@ -1,188 +0,0 @@ -No.,Field Description,Level Type,Short Name,nlvl -1,Height on pressure surface,isobaric,HGT,57 -2,Temperature on pressure surface,isobaric,TMP,57 -3,Specific humidity on pressure surface,isobaric,SPFH,57 -4,Relative humidity on pressure surface,isobaric,RH,57 -5,U component of wind on pressure surface,isobaric,UGRD,57 -6,V component of wind on pressure surface,isobaric,VGRD,57 -7,Vertical velocity on pressure surface,isobaric,DZDT,45 -8,Omega on pressure surface,isobaric,VVEL,45 -9,Absolute vorticity on pressure surface,isobaric,ABSV,57 -10,Ozone on pressure surface,isobaric,O3MR,32 -11,Cloud water mixing ratio on pressure surface,isobaric,CLWMR,39 -12,Cloud ice mixing ratio on pressure surface,isobaric,ICMR,39 -13,Rain mixing ratio on pressure surface,isobaric,RWMR,39 -14,Snow mixing ratio on pressure surface,isobaric,SNMR,39 -15,Graupel mixing ratio on pressure surface,isobaric,GRLE,39 -16,Composite radar reflectivity,entire atmosphere,REFC,1 -17,Mesinger (Membrane) sea level pressure,mean sea level,MSLET,1 -18,Shuell sea level pressure,mean sea level,PRES,1 -19,Temperature at 2m,height agl,TMP,1 -20,Specific humidity at 2m,height agl,SPFH,1 -21,Dew point temperature at 2m,height agl,DPT,1 -22,Relative humidity at 2m,height agl,RH,1 -23,U component of wind at 10m,height agl,UGRD,1 -24,V component of wind at 10m,height agl,VGRD,1 -25,Surface Pressure,surface,PRES,1 -26,Terrain height,surface,HGT,1 -27,Skin temperature,surface,TMP,1 -28,Soil temperature in between each soil layer,depth below land surface,TSOIL,4 -29,Soil moisture in between each soil layer,depth below land surface,SOILW,4 -30,Liquid soil moisture in between each soil layer,depth below land surface,SOILL,4 -31,Plant canopy surface water,surface,CNWAT,1 -32,Snow water equivalent,surface,WEASD,1 -33,Potential evaporation,surface,PEVPR,1 -34,Ice thickness,surface,ICETK,1 -35,Snow depth,surface,SNOD,1 -36,Wilting point,surface,WILT,1 -37,Field Capacity,surface,FLDCP,1 -38,Surface lifted index,surface,LFTX,1 -39,Best lifted index (4 layer),surface,4LFTX,1 -40,Parcel lifted index,pressure above ground,PLI,1 -41,Convective available potential energy,surface,CAPE,1 -42,Best cape,pressure above ground,CAPE,1 -43,Unstable cape,pressure above ground,CAPE,1 -44,Convective inhibition,surface,CIN,1 -45,Best cin,pressure above ground,CIN,1 -46,Unstable cin,pressure above ground,CIN,1 -47,Column integrated precipitable water,entire atmosphere,PWAT,1 -48,Helicity,height agl,HLCY,1 -49,U component storm motion,height agl,USTM,1 -50,V component storm motion,height agl,VSTM,1 -51,Accumulated total precipitation,surface,APCP,1 -52,Accumulated convective precipitation,surface,ACPCP,1 -53,Accumulated grid-scale precipitation,surface,NCPCP,1 -54,Continuous accumulated total precipitation,surface,APCP,1 -55,Continuous accumulated convective precipitation,surface,ACPCP,1 -56,Continuous accumulated grid-scale precipitation,surface,NCPCP,1 -57,Categorical rain (instantaneous),surface,CRAIN,1 -58,Categorical snow (instantaneous),surface,CSNOW,1 -59,Categorical ice pellets (instantaneous),surface,CICEP,1 -60,Categorical freezing rain (instantaneous),surface,CFRZR,1 -61,Categorical rain (average),surface,CRAIN,1 -62,Categorical snow (average),surface,CSNOW,1 -63,Categorical ice pellets (average),surface,CICEP,1 -64,Categorical freezing rain (average),surface,CFRZR,1 -65,Average precipitation rate,surface,PRATE,1 -66,Average convective precipitation rate,surface,CPRAT,1 -67,Average low cloud fraction,low cloud layer,TCDC,1 -68,Average mid cloud fraction,mid cloud layer,TCDC,1 -69,Average high cloud fraction,high cloud layer,TCDC,1 -70,Average total cloud fraction,entire atmosphere,TCDC,1 -71,Visibility,surface,VIS,1 -72,Average incoming surface shortwave radiation,surface,DSWRF,1 -73,Average clear sky incoming UV-B shortwave,surface,CDUVB,1 -74,Average incoming UV-B shortwave,surface,DUVB,1 -75,Average incoming surface longwave radiation,surface,DLWRF,1 -76,Average outgoing surface shortwave radiation,surface,USWRF,1 -77,Average outgoing surface longwave radiation,surface,ULWRF,1 -78,Average outgoing model top shortwave radiation,top of atmosphere,USWRF,1 -79,Average outgoing model top longwave radiation,top of atmosphere,ULWRF,1 -80,Total spectrum brightness temperature,top of atmosphere,BRTMP,1 -81,Roughness length,surface,SFCR,1 -82,Friction velocity,surface,FRICV,1 -83,Average surface sensible heat flux,surface,SHTFL,1 -84,Average ground heat flux,surface,GFLUX,1 -85,Average surface latent heat flux,surface,LHTFL,1 -86,Average surface zonal momentum flux,surface,UFLX,1 -87,Average surface meridional momentum flux,surface,VFLX,1 -88,Land sea mask (land=1 sea=0),surface,LAND,1 -89,Sea ice mask,surface,ICEC,1 -90,Average albedo,surface,ALBDO,1 -91,Pressure at tropopause,tropopause,PRES,1 -92,Height at tropopause,tropopause,HGT,1 -93,Temperature at tropopause,tropopause,TMP,1 -94,U component of wind at tropopause,tropopause,UGRD,1 -95,V component of wind at tropopause,tropopause,VGRD,1 -96,Wind shear at tropopause,tropopause,VWSH,1 -97,Temperature at flight levels,height msl,TMP,8 -98,U component of wind at flight levels,height msl,UGRD,8 -99,V component of wind at flight levels,height msl,VGRD,8 -100,Temperature at flight levels,height agl,TMP,2 -101,U component of wind at flight levels,height agl,UGRD,6 -102,V component of wind at flight levels,height agl,VGRD,6 -103,Pressure at flight levels,height agl,PRES,1 -104,Specific humidity at flight levels,height agl,SPFH,1 -105,Freezing level height,0 degree isotherm,HGT,1 -106,Freezing level relative humidity,0 degree isotherm,RH,1 -107,Highest freezing level height,highest tropospheric frz lvl,HGT,1 -108,Highest freezing level relative humidity,highest tropospheric frz lvl,RH,1 -109,Temperature in layer between pressure levels,pressure layer agl,TMP,6 -110,Dew point temperature in layer between pressure levels,pressure layer agl,DPT,1 -111,Specific humidity in layer between pressure levels,pressure layer agl,SPFH,6 -112,Relative humidity in layer between pressure levels,pressure layer agl,RH,6 -113,Precipitable water in layer between pressure levels,pressure layer agl,PWAT,1 -114,U component of wind in layer between pressure levels,pressure layer agl,UGRD,6 -115,V component of wind in layer between pressure levels,pressure layer agl,VGRD,6 -116,Relative humidity on sigma level 0.33-1.0,sigma level,RH,1 -117,Relative humidity on sigma level 0.44-1.0,sigma level,RH,1 -118,Relative humidity on sigma level 0.72-0.94,sigma level,RH,1 -119,Relative humidity on sigma level 0.44-0.72,sigma level,RH,1 -120,Temperature on sigma level 0.9950,sigma level,TMP,1 -121,Potential temperature on sigma level 0.9950,sigma level,POT,1 -122,Relative humidity on sigma level 0.9950,sigma level,RH,1 -123,U component of wind on sigma level 0.9950,sigma level,UGRD,1 -124,V component of wind on sigma level 0.9950,sigma level,VGRD,1 -125,Omega on sigma level 0.9950,sigma level,VVEL,1 -126,Maximum wind pressure level,max wind,PRES,1 -127,Maximum wind height,max wind,HGT,1 -128,U component of maximum wind,max wind,UGRD,1 -129,V component of maximum wind,max wind,VGRD,1 -130,Temperature at maximum wind level,max wind,TMP,1 -131,Planetary boundary layer height,surface,HPBL,1 -132,Convective cloud bottom pressure,convective cloud bottom,PRES,1 -133,Convective cloud top pressure,convective cloud top,PRES,1 -134,Average low cloud bottom pressure,low cloud bottom,PRES,1 -135,Average mid cloud bottom pressure,mid cloud bottom,PRES,1 -136,Average high cloud bottom pressure,high cloud bottom,PRES,1 -137,Average low cloud top pressure,low cloud top,PRES,1 -138,Average mid cloud top pressure,mid cloud top,PRES,1 -139,Average high cloud top pressure,high cloud top,PRES,1 -140,Average low cloud top temperature,low cloud top,TMP,1 -141,Average mid cloud top temperature,mid cloud top,TMP,1 -142,Average high cloud top temperature,high cloud top,TMP,1 -143,Total cloud fraction on convective cloud layer,entire atmosphere,TCDC,1 -144,Column integrated cloud water,entire atmosphere,CWAT,1 -145,Total column relative humidity,entire atmosphere,RH,1 -146,Total column ozone,entire atmosphere,TOZNE,1 -147,Surface wind gust,surface,GUST,1 -148,LCL level pressure,pressure layer agl,PLPL,1 -149,Cloud fraction on pressure surface,isobaric,TCDC,39 -150,U component of wind on theta surface,isentropic,UGRD,1 -151,V component of wind on theta surface,isentropic,VGRD,1 -152,Temperature on theta surface,isentropic,TMP,1 -153,Potential vorticity on theta surface,isentropic,PVORT,1 -154,Montgomery stream function on theta surface,isentropic,MNTSF,1 -155,U component of wind on constant PV surface,potential vorticity surface,UGRD,8 -156,V component of wind on constant PV surface,potential vorticity surface,VGRD,8 -157,Temperature on constant PV surface,potential vorticity surface,TMP,8 -158,Height on constant PV surface,potential vorticity surface,HGT,8 -159,Pressure on constant PV surface,potential vorticity surface,PRES,8 -160,Wind shear on constant PV surface,potential vorticity surface,VWSH,8 -161,Average planetary boundary layer cloud fraction,boundary layer cloud layer,TCDC,1 -162,Cloud work function,entire atmosphere,CWORK,1 -163,Average zonal gravity wave stress,surface,U-GWD,1 -164,Average meridional gravity wave stress,surface,V-GWD,1 -165,Average water runoff,surface,WATR,1 -166,Maximum 2m temperature,height agl,TMAX,1 -167,Minimum 2m temperature,height agl,TMIN,1 -168,ICAO height at maximum wind level,max wind,ICAHT,1 -169,ICAO height at tropopause,tropopause,ICAHT,1 -170,Sunshine duration,surface,SUNSD,1 -171,Transport u component of wind,planetary boundary layer,UGRD,1 -172,Transport v component of wind,planetary boundary layer,VGRD,1 -173,Ventilation rate,planetary boundary layer,VRATE,1 -174,Haines index,surface,HINDEX,1 -175,Fraction of frozen precipitation,surface,CPOFP,1 -176,Apparent temperature at 2m,height agl,APTMP,1 -177,Instantaneous precipitation rate,surface,PRATE,1 -178,Convective precipitation rate,surface,CPRAT,1 -179,Snow mixing ratio on model surface,hybrid,SNMR,1 -180,Rain mixing ratio on model surface,hybrid,RWMR,1 -181,Cloud water mixing ratio on model surface,hybrid,CLWMR,1 -182,Cloud ice mixing ratio on model surface,hybrid,ICMR,1 -183,Graupel mixing ratio on model surface,hybrid,GRLE,1 -184,Ice growth rate,height msl,ICEG,1 -185,Soil type,surface,SOTYP,1 -186,Vegetation cover,surface,VEG,1 -187,Sea ice skin temperature,surface,ICETMP,1 diff --git a/docs/MRW_GFSPRS_table.rst b/docs/MRW_GFSPRS_table.rst deleted file mode 100644 index a667226bf..000000000 --- a/docs/MRW_GFSPRS_table.rst +++ /dev/null @@ -1,11 +0,0 @@ -*************************************************** -Fields Requested in the UPP Parameter Table for MRW -*************************************************** - -Field description (column 1), level type as defined by WMO (column 2), abbreviated names -as they appear in the Grib2 output file (column 3), and number of levels output (column 4). - -.. csv-table:: - :file: MRW_GFSPRS_table.csv - :widths: 5, 40, 30, 15, 10 - :header-rows: 1 diff --git a/docs/Running.rst b/docs/Running.rst index 1cbef0fbd..c52db193f 100644 --- a/docs/Running.rst +++ b/docs/Running.rst @@ -64,7 +64,7 @@ Run Script Overview | **TOP_DIR**: Top level directory for building and running UPP | **DOMAINPATH**: Working directory for this run - | **UNIPOST_HOME**: Location of the **UPP** directory + | **UPP_HOME**: Location of the **UPP** directory | **POSTEXEC**: Location of the **UPP** executable | **modelDataPath**: Location of the model output data files to be processed | **txtCntrlFile**: Name and location of the flat text file that lists desired fields for @@ -82,7 +82,7 @@ Run Script Overview 3. Specify the format for the input model files and output UPP files - | **inFormat**: Format of the model data ("binarynemsiompiio": GFS only or "netcdf": GFS/LAM) + | **inFormat**: Format of the model data ("netcdfpara") | **outFormat**: Format of output from UPP ("grib2") 4. Specify the forecast cycles to be post-processed @@ -119,7 +119,3 @@ Upon a successful run, UPP will generate output files for each forecast hour in When executed with the provided run script, UPP provides log files in the post-processor working directory named :bolditalic:`upp.fHHH.out`, where :bolditalic:`HHH` is the forecast hour. These log files may be consulted for further run-time information in the event of an error. - -.. note:: - FV3 output is on a Guassian grid. To interpolate to a lat/lon or other projection, use wgrib2 (see - :ref:`Examples-of-wgrib2` section). diff --git a/docs/SRW_BGDAWP_table.csv b/docs/SRW_BGDAWP_table.csv deleted file mode 100644 index 6426ec95b..000000000 --- a/docs/SRW_BGDAWP_table.csv +++ /dev/null @@ -1,258 +0,0 @@ -No.,Field Description,Level Type,Short Name,nlvl -1,Pressure on model surface,hybrid,PRES,2 -2,Height on model surface,hybrid,HGT,2 -3,Temperature on model surface,hybrid,TMP,2 -4,Potential temperature on model surface,hybrid,POT,2 -5,Dew point temperature on model surface,hybrid,DPT,2 -6,Specific humidity on model surface,hybrid,SPFH,1 -7,Relative humidity on model surface,hybrid,RH,1 -8,U component of wind on model surface,hybrid,UGRD,2 -9,V component of wind on model surface,hybrid,VGRD,2 -10,Omega on model surface,hybrid,VVEL,1 -11,Vertical velocity on model surface,hybrid,DZDT,1 -12,Turbulent kinetic energy on model surface,hybrid,TKE,2 -13,Rain mixing ratio on model surface,hybrid,RWMR,2 -14,Snow mixing ratio on model surface,hybrid,SNMR,2 -15,Rimming factor for Ferrier scheme on model surface,hybrid,RIME,2 -16,Total condensate for Ferrier scheme on mode surface,hybrid,TCOND,2 -17,Radar reflectivity on model surface,hybrid,REFD,2 -18,Master length scale on model surface,hybrid,BMIXL,1 -19,Height on pressure surface,isobaric,HGT,46 -20,Temperature on pressure surface,isobaric,TMP,46 -21,Dew point temperature on pressure surface,isobaric,DPT,46 -22,Specific humidity on pressure surface,isobaric,SPFH,46 -23,Relative humidity on pressure surface,isobaric,RH,46 -24,Moisture convergence on pressure surface,isobaric,MCONV,2 -25,U component of wind on pressure surface,isobaric,UGRD,46 -26,V component of wind on pressure surface,isobaric,VGRD,46 -27,Vertical velocity on pressure surface,isobaric,DZDT,46 -28,Omega on pressure surface,isobaric,VVEL,46 -29,Absolute vorticity on pressure surface,isobaric,ABSV,10 -30,Geostrophic streamfunction on pressure surface,isobaric,STRM,2 -31,Turbulent kinetic energy on pressure surface,isobaric,TKE,46 -32,Cloud ice mixing ratio on pressure surface,isobaric,ICMR,46 -33,Cloud water mixing ratio on pressure surface,isobaric,CLWMR,46 -34,Rain mixing ratio on pressure surface,isobaric,RWMR,46 -35,Graupel mixing ratio on pressure surface,isobaric,GRLE,46 -36,Snow mixing ratio on pressure surface,isobaric,SNMR,46 -37,Rimming factor for Ferrier scheme on pressure surface,isobaric,RIME,46 -38,Mesinger (Membrane) sea level pressure,mean sea level,MSLET,1 -39,Shuell sea level pressure,mean sea level,PRES,1 -40,Temperature at 2m,height agl,TMP,1 -41,Specific humidity at 2m,height agl,SPFH,1 -42,Dew point temperature at 2m,height agl,DPT,1 -43,Relative humidity at 2m,height agl,RH,1 -44,U component of wind at 10m,height agl,UGRD,1 -45,V component of wind at 10m,height agl,VGRD,1 -46,Surface wind gust,surface,GUST,1 -47,LCL level pressure,pressure layer agl,PLPL,1 -48,Potential temperature at 10m,height agl,POT,1 -49,Specific humidity at 10m,height agl,SPFH,1 -50,Surface Pressure,surface,PRES,1 -51,Terrain height,surface,HGT,1 -52,Skin potential temperature,surface,POT,1 -53,Skin specific humidity,surface,SPFH,1 -54,Skin temperature,surface,TMP,1 -55,Soil temperature at 3m,depth below land surface,TSOIL,1 -56,Soil temperature in between each soil layer,depth below land surface,TSOIL,4 -57,Soil moisture in between each soil layer,depth below land surface,SOILW,4 -58,Liquid soil moisture in between each soil layer,depth below land surface,SOILL,4 -59,Total soil moisture,depth below land surface,SOILM,1 -60,Plant canopy surface water,surface,CNWAT,1 -61,Snow water equivalent,surface,WEASD,1 -62,Snow cover in percentage,surface,SNOWC,1 -63,Heat exchange coeff at surface,surface,SFEXC,1 -64,Vegetation cover,surface,VEG,1 -65,Vegetation type,surface,VGTYP,1 -66,Soil type,surface,SOTYP,1 -67,Snow free albedo,surface,SNFALB,1 -68,Maximum snow albedo,surface,MXSALB,1 -69,Canopy conductance,surface,CCOND,1 -70,Canopy conductance - solar component,surface,RCS,1 -71,Canopy conductance - temperature component,surface,RCT,1 -72,Canopy conductance - humidity component,surface,RCQ,1 -73,Canopy conductance - soil component,surface,RCSOL,1 -74,Soil moist reference,surface,SMREF,1 -75,Soil moist porosity,surface,POROS,1 -76,Number of root layers,surface,RLYRS,1 -77,Minimum stomatal resistance,surface,RSMIN,1 -78,Snow depth,surface,SNOD,1 -79,Air dry soil moisture,surface,SMDRY,1 -80,Soil moist wilting point,surface,WILT,1 -81,Soil moisture availability,depth below land surface,MSTAV,1 -82,Ground heat flux (instantaneous),surface,GFLUX,1 -83,Lifted index—surface based (500-1000 hPa),isobaric,LFTX,1 -84,Lifted index—best,pressure above ground,4LFTX,1 -85,Lifted index—parcel,pressure above ground,PLI,1 -86,Convective available potential energy,surface,CAPE,1 -87,Best cape,pressure above ground,CAPE,1 -88,Mixed layer cape,pressure above ground,CAPE,1 -89,Unstable cape,pressure above ground,CAPE,1 -90,Convective inhibition,surface,CIN,1 -91,Best cin,pressure above ground,CIN,1 -92,Mixed layer cin,pressure above ground,CIN,1 -93,Unstable cin,pressure above ground,CIN,1 -94,Column integrated precipitable water,entire atmosphere,PWAT,1 -95,Helicity,height agl,HLCY,2 -96,U component storm motion,height agl,USTM,1 -97,V component storm motion,height agl,VSTM,1 -98,Accumulated total precipitation,surface,APCP,1 -99,Accumulated grid-scale precipitation,surface,NCPCP,1 -100,Continuous accumulated total precipitation,surface,APCP,1 -101,Continuous accumulated grid-scale precipitation,surface,NCPCP,1 -102,Accumulated snowfall,surface,WEASD,1 -103,Accumulated total snow melt,surface,SNOM,1 -104,Accumulated storm surface runoff,surface,SSRUN,1 -105,Accumulated base flow runoff,surface,BGRUN,1 -106,Average water runoff,surface,WATR,1 -107,Categorical rain (instantaneous),surface,CRAIN,1 -108,Categorical snow (instantaneous),surface,CSNOW,1 -109,Categorical ice pellets (instantaneous),surface,CICEP,1 -110,Categorical freezing rain (instantaneous),surface,CFRZR,1 -111,Precipitation rate (instantaneous),surface,PRATE,1 -112,Fraction of frozen precipitation,surface,CPOFP,1 -113,Cloud water mixing ratio on model surface,hybrid,CLWMR,2 -114,Cloud ice mixing ratio on model surface,hybrid,ICMR,2 -115,Graupel mixing ratio on model surface,hybrid,GRLE,1 -116,Cloud fraction on model surface,hybrid,TCDC,2 -117,Low level cloud fraction,low cloud layer,LCDC,1 -118,Mid level cloud fraction,mid cloud layer,MCDC,1 -119,High level cloud fraction,high cloud layer,HCDC,1 -120,Total cloud fraction,entire atmosphere,TCDC,1 -121,Total cloud fraction (time-averaged),entire atmosphere,TCDC,1 -122,stratospheric cloud fraction (time-averaged),entire atmosphere,CDLYR,1 -123,Visibility,surface,VIS,1 -124,GSD visibility,cloud top,VIS,1 -125,Above-ground height of LCL,adiabatic condensation from surface,HGT,1 -126,Pressure of LCL,adiabatic condensation from surface,PRES,1 -127,Outgoing surface shortwave radiation (instantaneous),surface,USWRF,1 -128,Outgoing surface longwave radiation (instantaneous),surface,ULWRF,1 -129,Incoming surface shortwave radiation (time-averaged),surface,DSWRF,1 -130,Incoming surface longwave radiation (time-averaged),surface,DLWRF,1 -131,Outgoing surface shortwave radiation (time-averaged),surface,USWRF,1 -132,Outgoing surface longwave radiation (time-averaged),surface,ULWRF,1 -133,Outgoing model top shortwave radiation (time-averaged),top of atmosphere,USWRF,1 -134,Outgoing model top longwave radiation (time-averaged),top of atmosphere,ULWRF,1 -135,Outgoing longwave at top of atmosphere (instantaneous),top of atmosphere,ULWRF,1 -136,Total spectrum brightness temperature,top of atmosphere,BRTMP,1 -137,Incoming surface shortwave radiation (instantaneous),surface,DSWRF,1 -138,Incoming surface longwave radiation (instantaneous),surface,DLWRF,1 -139,Clear sky incoming surface shortwave (instantaneous),surface,CSDSF,1 -140,Roughness length,surface,SFCR,1 -141,Friction velocity,surface,FRICV,1 -142,Surface drag coefficient,surface,CD,1 -143,Surface u wind stress,surface,UFLX,1 -144,Surface v wind stress,surface,VFLX,1 -145,Surface sensible heat flux (time-averaged),surface,SHTFL,1 -146,Ground heat flux (time-averaged),surface,GFLUX,1 -147,Snow phase change heat flux (time-averaged),surface,SNOHF,1 -148,Surface latent heat flux (time-averaged),surface,LHTFL,1 -149,Accumulated surface evaporation,surface,EVP,1 -150,Accumulated potential evaporation,surface,PEVAP,1 -151,Surface sensible heat flux (instantaneous),surface,SHTFL,1 -152,Surface latent heat flux (instantaneous),surface,LHTFL,1 -153,Latitude,surface,NLAT,1 -154,Longitude,surface,ELON,1 -155,Land sea mask (land=1 sea=0),surface,LAND,1 -156,Sea ice mask,surface,ICEC,1 -157,Surface albedo,surface,ALBDO,1 -158,Sea surface temperature,surface,WTMP,1 -159,Pressure at tropopause,tropopause,PRES,1 -160,Height at tropopause,tropopause,HGT,1 -161,Temperature at tropopause,tropopause,TMP,1 -162,Potential temperature at tropopause,tropopause,POT,1 -163,U component of wind at tropopause,tropopause,UGRD,1 -164,V component of wind at tropopause,tropopause,VGRD,1 -165,Wind shear at tropopause,tropopause,VWSH,1 -166,U component of 0-6km level wind shear,height agl,VUCSH,1 -167,V-component of 0-6km level wind shear,height agl,VVCSH,1 -168,Temperature at flight levels,height msl,TMP,10 -169,Temperature at flight levels,height agl,TMP,4 -170,U component of wind at flight levels,height msl,UGRD,10 -171,U component of wind at flight levels,height agl,UGRD,4 -172,V component of wind at flight levels,height msl,VGRD,10 -173,V component of wind at flight levels,height agl,VGRD,4 -174,Specific humidity at flight levels,height msl,SPFH,1 -175,Specific humidity at flight levels,height agl,SPFH,4 -176,Pressure at flight levels,height agl,PRES,4 -177,Freezing level height,0 degree isotherm,HGT,1 -178,Freezing level relative humidity,0 degree isotherm,RH,1 -179,Highest freezing level height,highest tropospheric frz lvl,HGT,1 -180,Lowest wet bulb zero height,lowest lvl wet bulb zero,HGT,1 -181,Pressure in boundary layer (30 mb means),pressure agl,PRES,6 -182,Temperature in boundary layer (30 mb means),pressure agl,TMP,6 -183,Potential temperature in boundary layer (30 mb means),pressure agl,POT,1 -184,Dew point temperature in boundary layer (30 mb means),pressure agl,DPT,1 -185,Specific humidity in boundary layer (30 mb means),pressure agl,SPFH,6 -186,RH in boundary layer (30 mb means),pressure agl,RH,6 -187,Moisture convergence in boundary layer (30 mb means),pressure agl,MCONV,1 -188,Precipitable water in boundary layer (30 mb means),pressure agl,PWAT,1 -189,U wind in boundary layer (30 mb means),pressure agl,UGRD,6 -190,V wind in boundary layer (30 mb means),pressure agl,VGRD,6 -191,Omega in boundary layer (30 mb means),pressure agl,VVEL,3 -192,Cloud bottom pressure,cloud base,PRES,1 -193,Cloud top pressure,cloud top,PRES,1 -194,Cloud top temperature,cloud top,TMP,1 -195,Cloud bottom height (above MSL),cloud base,HGT,1 -196,Cloud top height (above MSL),cloud top,HGT,1 -197,Maximum wind pressure level,max wind,PRES,1 -198,Maximum wind height,max wind,HGT,1 -199,U-component of maximum wind,max wind,UGRD,1 -200,V-component of maximum wind,max wind,VGRD,1 -201,Composite radar reflectivity,entire atmosphere,REFC,1 -202,Composite rain radar reflectivity,entire atmosphere,REFZR,1 -203,Composite ice radar reflectivity,entire atmosphere,REFZI,1 -204,Radar reflectivity at certain above ground heights,height agl,REFD,2 -205,Radar reflectivity from rain,height agl,REFZR,2 -206,Radar reflectivity from ice,height agl,REFZI,2 -207,Planetary boundary layer height,surface,HPBL,1 -208,Grid scale cloud bottom pressure,grid scale cloud bottom,PRES,1 -209,Grid scale cloud top pressure,grid scale cloud top,PRES,1 -210,Column integrated cloud water,entire atmosphere,TCOLW,1 -211,Column integrated cloud ice,entire atmosphere,TCOLI,1 -212,Column integrated rain,entire atmosphere,TCOLR,1 -213,Column integrated snow,entire atmosphere,TCOLS,1 -214,Column integrated total condensate,entire atmosphere,TCOLC,1 -215,Column integrated graupel,entire atmosphere,TCOLG,1 -216,Column integrated super cool liquid water,entire atmosphere,TCLSW,1 -217,Column integrated melting ice,entire atmosphere,TCOLM,1 -218,Height of lowest level super cool liquid water,lwst bot lvl of supercooled liq wtr,HGT,1 -219,Height of highest level super cool liquid water,hghst top lvl of supercooled liq wtr,HGT,1 -220,Ceiling height,cloud ceiling,HGT,1 -221,Accumulated land surface model precipitation,surface,LSPA,1 -222,Model top pressure,top of atmosphere,PRES,1 -223,Total column shortwave temperature tendency,entire atmosphere,SWHR,1 -224,Total column longwave temperature tendency,entire atmosphere,LWHR,1 -225,Total column gridded temperature tendency,entire atmosphere,LRGHR,1 -226,Column integrated moisture convergence,entire atmosphere,MCONV,1 -227,Temperature on sigma levels,sigma level,TMP,5 -228,Planetary boundary layer regime,surface,PBLREG,1 -229,Transport wind u component,planetary boundary layer,UGRD,1 -230,Transport wind v component,planetary boundary layer,VGRD,1 -231,Richardson number planetary boundary layer height,planetary boundary layer,HGT,1 -232,Mixing height,surface,MIXHT,1 -233,Radar echo top,entire atmosphere,RETOP,1 -234,Ventilation rate,planetary boundary layer,VRATE,1 -235,Haines index,surface,HINDEX,1 -236,Maximum 2m temperature,height agl,TMAX,1 -237,Minimum 2m temperature,height agl,TMIN,1 -238,Maximum 2m RH,height agl,MAXRH,1 -239,Minimum 2m RH,height agl,MINRH,1 -240,Maximum U-component wind at 10m,height agl,MAXUW,1 -241,Maximum V-component wind at 10m,height agl,MAXVW,1 -242,Maximum wind speed at 10m,height agl,WIND,1 -243,Maximum 1km reflectivity,height agl,MAXREF,1 -244,Maximum updraft vertical velocity,isobaric layer,MAXUVV,1 -245,Maximum downdraft vertical velocity,isobaric layer,MAXDVV,1 -246,Lightning,surface,LTNG,1 -247,Radar derived vertically integrated liquid,entire atmosphere,VIL,1 -248,Updraft helicity (2-5 km),height agl,UPHL,1 -249,Maximum updraft helicity (2-5 km),height agl,MXUPHL,1 -250,Minimum updraft helicity (2-5 km),height agl,MNUPHL,1 -251,Minimum updraft helicity (0-3 km),height agl,MNUPHL,1 -252,Maximum updraft helicity (0-3 km),height agl,MXUPHL,1 -253,Maximum relative vertical vorticity (0-1 km),height agl,RELV,1 -254,Maximum relative vertical vorticity at hybrid level 1,hybrid,RELV,1 -255,Maximum relative vertical vorticity (0-2 km),height agl,RELV,1 -256,Maximum derived radar reflectivity at -10 C,isothermal,MAXREF,1 -257,Radar reflectivity at -10 C,isothermal,REFD,1 \ No newline at end of file diff --git a/docs/SRW_BGDAWP_table.rst b/docs/SRW_BGDAWP_table.rst deleted file mode 100644 index f578bd310..000000000 --- a/docs/SRW_BGDAWP_table.rst +++ /dev/null @@ -1,11 +0,0 @@ -********************************************************** -Fields Requested in the UPP Parameter Table for SRW BGDAWP -********************************************************** - -Field description (column 1), level type as defined by WMO (column 2), abbreviated names -as they appear in the Grib2 output file (column 3), and number of levels output (column 4). - -.. csv-table:: - :file: SRW_BGDAWP_table.csv - :widths: 5, 40, 30, 15, 10 - :header-rows: 1 diff --git a/docs/SRW_BGRD3D_table.csv b/docs/SRW_BGRD3D_table.csv deleted file mode 100644 index d9567b15d..000000000 --- a/docs/SRW_BGRD3D_table.csv +++ /dev/null @@ -1,217 +0,0 @@ -No.,Field Description,Level Type,Short Name,nlvl -1,Height on pressure surface,isobaric,HGT,4 -2,Temperature on pressure surface,isobaric,TMP,5 -3,Relative humidity on pressure surface,isobaric,RH,4 -4,U component of wind on pressure surface,isobaric,UGRD,4 -5,V component of wind on pressure surface,isobaric,VGRD,4 -6,Omega on pressure surface,isobaric,VVEL,4 -7,Specific humidity on pressure surface,isobaric,SPFH,4 -8,Absolute vorticity on pressure surface,isobaric,ABSV,4 -9,Pressure on model surface,hybrid,PRES,64 -10,Height on model surface,hybrid,HGT,64 -11,Temperature on model surface,hybrid,TMP,64 -12,Specific humidity on model surface,hybrid,SPFH,64 -13,U component of wind on model surface,hybrid,UGRD,64 -14,V component of wind on model surface,hybrid,VGRD,64 -15,Omega on model surface,hybrid,VVEL,64 -16,Vertical velocity on model surface,hybrid,DZDT,64 -17,Turbulent kinetic energy on model surface,hybrid,TKE,64 -18,Temperature tendency from grid scale latent heat release (time-averaged),hybrid,LRGHR,64 -19,Mesinger (Membrane) sea level pressure,mean sea level,MSLET,1 -20,Shuell sea level pressure,mean sea level,PRES,1 -21,Temperature at 2m,height agl,TMP,1 -22,Specific humidity at 2m,height agl,SPFH,1 -23,Dew point temperature at 2m,height agl,DPT,1 -24,Relative humidity at 2m,height agl,RH,1 -25,U component of wind at 10m,height agl,UGRD,1 -26,V component of wind at 10m,height agl,VGRD,1 -27,Potential temperature at 10m,height agl,POT,1 -28,Specific humidity at 10m,height agl,SPFH,1 -29,Surface Pressure,surface,PRES,1 -30,Terrain height,surface,HGT,1 -31,Skin potential temperature,surface,POT,1 -32,Skin specific humidity,surface,SPFH,1 -33,Skin temperature,surface,TMP,1 -34,Maximum updraft vertical velocity (10-100 hPa),isobaric,MAXUVV,1 -35,Maximum downdraft vertical velocity (10-100 hPa),isobaric,MAXDVV,1 -36,Maximum updraft helicity (0-3 km),height agl,MXUPHL,1 -37,Maximum updraft helicity (2-5 km),height agl,MXUPHL,1 -38,Minimum updraft helicity (2-5 km),height agl,MNUPHL,1 -39,Minimum updraft helicity (0-3 km),height agl,MNUPHL,1 -40,Maximum relative vertical vorticity (0-1 km),height agl,RELV,1 -41,Maximum relative vertical vorticity at hybrid level 1,hybrid,RELV,1 -42,Maximum relative vertical vorticity (0-2 km),height agl,RELV,1 -43,Maximum U-component wind at 10m,height agl,MAXUW,1 -44,Maximum V-component wind at 10m,height agl,MAXVW,1 -45,Maximum derived radar reflectivity at 1 km,height agl,MAXREF,1 -46,Maximum derived radar reflectivity at -10 C,isothermal,MAXREF,1 -47,Radar reflectivity at -10 C,isothermal,REFD,1 -48,Maximum 2m temperature,height agl,TMAX,1 -49,Minimum 2m temperature,height agl,TMIN,1 -50,Maximum 2m RH,height agl,MAXRH,1 -51,Minimum 2m RH,height agl,MINRH,1 -52,Soil temperature in between each soil layer,depth below land surface,TSOIL,4 -53,Soil moisture in between each soil layer,depth below land surface,SOILW,4 -54,Total soil moisture,depth below land surface,SOILM,1 -55,Heat exchange coeff at surface,surface,SFEXC,1 -56,Vegetation cover,surface,VEG,1 -57,Soil moisture availability,depth below land surface,MSTAV,1 -58,Soil temperature at 3m,depth below land surface,TSOIL,1 -59,Ground heat flux (instantaneous),surface,GFLUX,1 -60,Plant canopy surface water,surface,CNWAT,1 -61,Snow water equivalent,surface,WEASD,1 -62,Lifted index—best,pressure above ground,4LFTX,1 -63,Column integrated precipitable water,entire atmosphere,PWAT,1 -64,Accumulated total precipitation,surface,APCP,1 -65,Accumulated grid-scale precipitation,surface,NCPCP,1 -66,Continuous accumulated total precipitation,surface,APCP,1 -67,Continuous accumulated grid-scale precipitation,surface,NCPCP,1 -68,Accumulated snowfall,surface,WEASD,1 -69,Accumulated total snow melt,surface,SNOM,1 -70,Accumulated storm surface runoff,surface,SSRUN,1 -71,Accumulated base flow runoff,surface,BGRUN,1 -72,Categorical rain (instantaneous),surface,CRAIN,1 -73,Categorical snow (instantaneous),surface,CSNOW,1 -74,Categorical ice pellets (instantaneous),surface,CICEP,1 -75,Categorical freezing rain (instantaneous),surface,CFRZR,1 -76,Precipitation rate (instantaneous),surface,PRATE,1 -77,Fraction of frozen precipitation,surface,CPOFP,1 -78,Cloud water mixing ratio on model surface,hybrid,CLWMR,64 -79,Cloud ice mixing ratio on model surface,hybrid,ICMR,64 -80,Graupel mixing ratio on mmodel surface,hybrid,GRLE,64 -81,Cloud fraction on model surface,hybrid,TCDC,64 -82,Rain mixing ratio on model surface,hybrid,RWMR,64 -83,Snow mixing ratio on model surface,hybrid,SNMR,64 -84,Rimming factor for Ferrier scheme on model surface,hybrid,RIME,64 -85,Total condensate for Ferrier scheme on mode surface,hybrid,TCOND,64 -86,Model level fraction of rain for Ferrier scheme,hybrid,FRAIN,64 -87,Model level fraction of ice for Ferrier scheme,hybrid,FICE,64 -88,Low level cloud fraction,low cloud layer,LCDC,1 -89,Mid level cloud fraction,mid cloud layer,MCDC,1 -90,High level cloud fraction,high cloud layer,HCDC,1 -91,Total cloud fraction,entire atmosphere,TCDC,1 -92,Total cloud fraction (time-averaged),entire atmosphere,TCDC,1 -93,stratospheric cloud fraction (time-averaged),entire atmosphere,CDLYR,1 -94,Outgoing surface shortwave radiation (instantaneous),surface,USWRF,1 -95,Outgoing surface longwave radiation (instantaneous),surface,ULWRF,1 -96,Incoming surface shortwave radiation (time-averaged),surface,DSWRF,1 -97,Incoming surface longwave radiation (time-averaged),surface,DLWRF,1 -98,Outgoing surface shortwave radiation (time-averaged),surface,USWRF,1 -99,Outgoing surface longwave radiation (time-averaged),surface,ULWRF,1 -100,Outgoing model top shortwave radiation (time-averaged),top of atmosphere,USWRF,1 -101,Outgoing model top longwave radiation (time-averaged),top of atmosphere,ULWRF,1 -102,Incoming surface shortwave radiation (instantaneous),surface,DSWRF,1 -103,Incoming surface longwave radiation (instantaneous),surface,DLWRF,1 -104,Clear sky incoming surface shortwave (instantaneous),surface,CSDSF,1 -105,Roughness length,surface,SFCR,1 -106,Friction velocity,surface,FRICV,1 -107,Surface drag coefficient,surface,CD,1 -108,Surface u wind stress,surface,UFLX,1 -109,Surface v wind stress,surface,VFLX,1 -110,Surface sensible heat flux (time-averaged),surface,SHTFL,1 -111,Ground heat flux (time-averaged),surface,GFLUX,1 -112,Snow phase change heat flux (time-averaged),surface,SNOHF,1 -113,Surface latent heat flux (time-averaged),surface,LHTFL,1 -114,Accumulated surface evaporation,surface,EVP,1 -115,Accumulated potential evaporation,surface,PEVAP,1 -116,Surface sensible heat flux (instantaneous),surface,SHTFL,1 -117,Surface latent heat flux (instantaneous),surface,LHTFL,1 -118,Latitude,surface,NLAT,1 -119,Longitude,surface,ELON,1 -120,Land sea mask (land=1 sea=0),surface,LAND,1 -121,Sea ice mask,surface,ICEC,1 -122,Mass point at eta surface mask,surface,LMH,1 -123,Velocity point at eta surface mask,surface,LMV,1 -124,Surface albedo,surface,ALBDO,1 -125,Sea surface temperature,surface,WTMP,1 -126,Pressure in boundary layer (30 mb means),pressure agl,PRES,6 -127,Temperature in boundary layer (30 mb means),pressure agl,TMP,6 -128,Potential temperature in boundary layer (30 mb means),pressure agl,POT,1 -129,Dew point temperature in boundary layer (30 mb means),pressure agl,DPT,1 -130,Specific humidity in boundary layer (30 mb means),pressure agl,SPFH,6 -131,RH in boundary layer (30 mb means),pressure agl,RH,6 -132,Moisture convergence in boundary layer (30 mb means),pressure agl,MCONV,1 -133,Precipitable water in boundary layer (30 mb means),pressure agl,PWAT,1 -134,U wind in boundary layer (30 mb means),pressure agl,UGRD,6 -135,V wind in boundary layer (30 mb means),pressure agl,VGRD,6 -136,Accumulated land surface model precipitation,surface,LSPA,1 -137,Model top pressure,top of atmosphere,PRES,1 -138,Pressure thickness,hybrid,PRES,1 -139,Sigma pressure thickness,hybrid,PRES,1 -140,Plant canopy surface water,surface,CNWAT,1 -141,Ground heat flux (instantaneous),surface,GFLUX,1 -142,Lifted index—surface based (500-1000 hPa),isobaric,LFTX,1 -143,Convective available potential energy,surface,CAPE,1 -144,Best cape,pressure above ground,CAPE,1 -145,Mixed layer cape,pressure above ground,CAPE,1 -146,Unstable cape,pressure above ground,CAPE,1 -147,Convective inhibition,surface,CIN,1 -148,Best cin,pressure above ground,CIN,1 -149,Mixed layer cin,pressure above ground,CIN,1 -150,Unstable cin,pressure above ground,CIN,1 -151,LCL level pressure,pressure layer agl,PLPL,1 -152,Helicity,height agl,HLCY,2 -153,U component storm motion,height agl,USTM,1 -154,V component storm motion,height agl,VSTM,1 -155,Cloud bottom pressure,cloud base,PRES,1 -156,Cloud top pressure,cloud top,PRES,1 -157,Cloud top temperature,cloud top,TMP,1 -158,Pressure at tropopause,tropopause,PRES,1 -159,Height at tropopause,tropopause,HGT,1 -160,Temperature at tropopause,tropopause,TMP,1 -161,U component of wind at tropopause,tropopause,UGRD,1 -162,V component of wind at tropopause,tropopause,VGRD,1 -163,Wind shear at tropopause,tropopause,VWSH,1 -164,Temperature at flight levels,height msl,TMP,10 -165,U component of wind at flight levels,height msl,UGRD,10 -166,V component of wind at flight levels,height msl,VGRD,10 -167,Freezing level height,0 degree isotherm,HGT,1 -168,Freezing level relative humidity,0 degree isotherm,RH,1 -169,Highest freezing level height,highest tropospheric frz lvl,HGT,1 -170,Maximum wind pressure level,max wind,PRES,1 -171,Maximum wind height,max wind,HGT,1 -172,U-component of maximum wind,max wind,UGRD,1 -173,V-component of maximum wind,max wind,VGRD,1 -174,Maximum wind speed at 10m,height agl,WIND,1 -175,Cloud bottom height (above MSL),cloud base,HGT,1 -176,Cloud top height (above MSL),cloud top,HGT,1 -177,Visibility,surface,VIS,1 -178,Composite radar reflectivity,entire atmosphere,REFC,1 -179,Grid scale cloud bottom pressure,grid scale cloud bottom,PRES,1 -180,Grid scale cloud top pressure,grid scale cloud top,PRES,1 -181,Column integrated cloud water,entire atmosphere,TCOLW,1 -182,Column integrated cloud ice,entire atmosphere,TCOLI,1 -183,Column integrated rain,entire atmosphere,TCOLR,1 -184,Column integrated snow,entire atmosphere,TCOLS,1 -185,Column integrated total condensate,entire atmosphere,TCOLC,1 -186,Column integrated graupel,entire atmosphere,TCOLG,1 -187,Vegetation type,surface,VGTYP,1 -188,Soil type,surface,SOTYP,1 -189,Canopy conductance,surface,CCOND,1 -190,Planetary boundary layer height,surface,HPBL,1 -191,Snow depth,surface,SNOD,1 -192,Snow sublimation,surface,SBSNO,1 -193,Air dry soil moisture,surface,SMDRY,1 -194,Soil moist porosity,surface,POROS,1 -195,Minimum stomatal resistance,surface,RSMIN,1 -196,Number of root layers,surface,RLYRS,1 -197,Soil moist wilting point,surface,WILT,1 -198,Soil moist reference,surface,SMREF,1 -199,Canopy conductance - solar component,surface,RCS,1 -200,Canopy conductance - temperature component,surface,RCT,1 -201,Canopy conductance - humidity component,surface,RCQ,1 -202,Canopy conductance - soil component,surface,RCSOL,1 -203,Potential evaporation,surface,PEVPR,1 -204,Surface wind gust,surface,GUST,1 -205,Lowest wet bulb zero height,lowest lvl wet bulb zero,HGT,1 -206,Leaf area index,surface,LAI,1 -207,Clear sky incoming surface shortwave (instantaneous),surface,CSDSF,1 -208,Cloud fraction on sigma surface,sigma,TCDC,22 -209,Richardson number planetary boundary layer height,planetary boundary layer,HGT,1 -210,Mixing height,surface,MIXHT,1 -211,Temperature at 10m,height agl,TMP,1 -212,Time-averaged percentage snow cover,surface,SNOWC,1 -213,Time-averaged surface pressure,surface,PRES,1 -214,Time-averaged 10m temperature,height agl,TMP,1 -215,Time-averaged mass exchange coefficient,surface,AKHS,1 -216,Time-averaged wind exchange coefficient,surface,AKMS,1 \ No newline at end of file diff --git a/docs/SRW_BGRD3D_table.rst b/docs/SRW_BGRD3D_table.rst deleted file mode 100644 index 246c178a1..000000000 --- a/docs/SRW_BGRD3D_table.rst +++ /dev/null @@ -1,11 +0,0 @@ -********************************************************** -Fields Requested in the UPP Parameter Table for SRW BGRD3D -********************************************************** - -Field description (column 1), level type as defined by WMO (column 2), abbreviated names -as they appear in the Grib2 output file (column 3), and number of levels output (column 4). - -.. csv-table:: - :file: SRW_BGRD3D_table.csv - :widths: 5, 40, 30, 15, 10 - :header-rows: 1 diff --git a/docs/UFS_unified_variables_table.csv b/docs/UFS_unified_variables_table.csv new file mode 100644 index 000000000..e863c9295 --- /dev/null +++ b/docs/UFS_unified_variables_table.csv @@ -0,0 +1,244 @@ +Field Description,Model Variable NetCDF Name,UPP Internal Name,Dimensions,dyn (atm) or phy (sfc),Notes +U-component of wind,ugrd,uh,3d,dyn, +V-component of wind,vgrd,vh,3d,dyn, +Specific humidity,spfh,q,3d,dyn, +Temperature,tmp,t,3d,dyn, +Ozone mixing ratio,o3mr,o3,3d,dyn, +Geometric vertical velocity,dzdt,wh,3d,dyn, +Cloud water mixing ratio,clwmr,qqw,3d,dyn, +Layer thickness in pressure on hybrid levels,dpres,dpres,3d,dyn, +Layer thickness in height,delz,na,3d,dyn, +Ice mixing ratio,icmr,qqi,3d,dyn, +Rain mixing ratio,rwmr,qqr,3d,dyn, +Snow mixing ratio,snmr,qqs,3d,dyn, +Graupel mixing ratio,grle,qqg,3d,dyn, +Instantaneous 3d cloud fraction,cld_amt,cfr,3d,dyn,imp_physics = 11 +Instantaneous 3d cloud fraction,cldfra,cfr,3d,phy,imp_physics ≠ 11 +Max hourly updraft velocity,upvvelmax,w_up_max,2d,dyn,regional FV3 +Max hourly downdraft velocity,dnvvelmax,w_dn_max,2d,dyn,regional FV3 +Max hourly updraft helicity,uhmax25,up_heli_max,2d,dyn,regional FV3 +Min hourly updraft helicity,uhmin25,up_heli_min,2d,dyn,regional FV3 +Max hourly 0-3km updraft helicity,uhmax03,up_heli_max03,2d,dyn,regional FV3 +Min hourly 0-3km updraft helicity,uhmin03,up_heli_min03,2d,dyn,regional FV3 +Max 0-1km relative vorticity max,maxvort01,rel_vort_max01,2d,dyn,regional FV3 +Max 0-2km relative vorticity max,maxvort02,rel_vort_max,2d,dyn,regional FV3 +Max hybrid level 1 relative vorticity max,maxvorthy1,rel_vort_maxhy1,2d,dyn,regional FV3 +Surface height,hgtsfc,"zint(:,:,LM+1)",2d,dyn, +Reflectivity,refl_10cm,REF_10CM,3d,phy, +Turbulence kinetic energy,qke,q2,3d,phy, +Ice-friendly aerosol number concentration,nifa,qqnwfa,3d,phy, +Water-friendly aerosol number concentration,nwfa,qqnwfa,3d,phy, +Land mask,land,sm,2d,phy, +Sea ice mask,icec,sice,2d,phy, +PBL height,hpbl,pblh,2d,phy, +Frictional velocity,fricv,ustar,2d,phy, +Roughness length,sfcr,z0,2d,phy, +Surface exchange coefficient,sfexc,SFCEXC,2d,phy, +Aerodynamic conductance,acond,acond,2d,phy, +Mid day avg albedo,albdo_ave,avgalbedo,2d,phy, +Surface potential temperature,tmpsfc,ths,2d,phy, +Foundation temperature,tref,fdnsst,2d,phy, +Convective precip in m per physics time step,cpratb_ave,avgcprate,2d,phy, +Convective precip - coninuous bucket,cprat_ave,avgcprate_cont,2d,phy, +Average precip rate in m per physics time step,prateb_ave,avgprec,2d,phy, +Average precip rate - continuous bucket,prate_ave,avgprec_cont,2d,phy, +Precip rate,tprcp,prec,2d,phy, +Convective precip rate,cnvprcp,cprate,2d,phy, +Max hourly surface precip rate,pratemax,prate_max,2d,phy, +Max hourly 1 km agl reflectivity,refdmax,refd_max,2d,phy, +Max hourly -10C reflectivity,refdmax263k,refdm10c_max,2d,phy, +Max hourly u comp of 10m agl wind,u10max,u10max,2d,phy, +Max hourly v comp of 10m agl wind,v10max,v10max,2d,phy, +Max hourly 10m agl wind speed,spd10max,wspd10max,2d,phy, +Instantaneous snow water equivalent,weasd,sno,2d,phy, +Average snow cover,snowc_ave,snoavg,2d,phy, +Snow depth in mm,snod,si,2d,phy, +2m temperature,tmp2m,tshltr,2d,phy, +2m specific humidity,spfh2m,qshltr,2d,phy, +Time-averaged column cloud fraction,tcdc_aveclm,avgtcdc,2d,phy, +Maximum snow albedo,snoalb,mxsnal,2d,phy, +Land fraction,lfrac,landfrac,2d,phy, +Average high cloud fraction,tcdc_avehcl,avgcfrach,2d,phy, +Average low cloud fraction,tcdc_avelcl,avgcfracl,2d,phy, +Average mid cloud fraction,tcdc_avemcl,avgcfracm,2d,phy, +Instantaneous convective cloud fraction,tcdccnvcl,cnvcfr,2d,phy, +Slope type,sltyp,islope,2d,phy, +Plant canopy sfc water in m,cnwat,cmc,2d,phy, +Frozen precip fraction,cpofp,sr,2d,phy, +Sea ice skin temperature,tisfc,ti,2d,phy, +Vegetation fraction,veg,vegfrc,2d,phy, +Liquid volumetric soil moisture,soill1/soill2/soill3/soill4,sh2o,2d>3d,phy,all soil levels read into array +Volumetric soil moisture,soilw1/soilw2/soilw3/soilw4.....,smc,2d>3d,phy,"all soil levels read into array, L5-9 RUC only" +Soil temperature,soilt1/soilt2/soilt3/soilt4.....,stc,2d>3d,phy,"all soil levels read into array, L5-9 RUC only" +Time averaged incoming surface longwave,dlwrf_ave,alwin,2d,phy, +Instantaneous incoming surface longwave,dlwrf,rlwin,2d,phy, +Time averaged outgoing surface longwave,ulwrf_ave,alwout,2d,phy, +Instataneous outgoing surface longwave,ulwrf,radot,2d,phy, +Time average outgoing model top longwave,ulwrf_avetoa,alwtoa,2d,phy, +Time averaged incoming surface shortwave,dswrf_ave,aswin,2d,phy, +Instantaneous incoming surface shortwave,dswrf,rswin,2d,phy, +Time averaged incoming sfc uv-b,duvb_ave,auvbin,2d,phy, +Time averaged incoming sfc clear sky uv-b,cduvb_ave,auvbinc,2d,phy, +Time averaged outgoing sfc shortwave,uswrf_ave,aswout,2d,phy, +Inst outgoing sfc shortwave,uswrf,rswout,2d,phy, +Time averaged model top incoming shortwave,dswrf_avetoa,aswintoa,2d,phy, +Time averaged model top outgoing shortwave,uswrf_avetoa,aswtoa,2d,phy, +Time averaged surface sensible heat flux,shtfl_ave,sfcshx,2d,phy, +Inst surface sensible heat flux,shtfl,twbs,2d,phy, +Time averaged surface latent heat flux,lhtfl_ave,sfclhx,2d,phy, +Inst surface latent heat flux,lhtfl,qwbs,2d,phy, +Time averaged ground heat flux,gflux_ave,subshx,2d,phy, +Instantaneous ground heat flux,gflux,grnflx,2d,phy, +Time averaged zonal momentum flux,uflx_ave,sfcux,2d,phy, +Time averaged meridional momentum flux,vflx_ave,sfcvx,2d,phy, +Instantaneous zonal momentum flux,uflx,sfcuxi,2d,phy, +Instantaneous meridional momentum flux,vflx,sfcvxi,2d,phy, +Time averaged zonal gravity wave stress,u-gwd_ave,gtaux,2d,phy, +Time averaged meridional gravity wave stress,v-gwd_ave,gtauy,2d,phy, +Time averaged accumulated potential evaporation,pevpr_ave,avgpotevp,2d,phy, +Instantaneous potential evaporation,pevpr,potevp,2d,phy, +10 m u-wind component,ugrd10m,u10,2d,phy, +10 m v-wind component,vgrd10m,v10,2d,phy, +Vegetation type,vtype,ivgtyp,2d,phy, +Soil type,sotyp,isltyp,2d,phy, +Instantaneous convective cloud top pressure,prescnvclt,ptop,2d,phy, +Instantaneous convective cloud bottom pressure,prescnvclb,pbot,2d,phy, +Time averaged low cloud top pressure,pres_avelct,ptopl,2d,phy, +Time averaged low cloud bottom pressure,pres_avelcb,pbotl,2d,phy, +Time averaged low cloud top temperature,tmp_avelct,Ttopl,2d,phy, +Time averaged middle cloud top pressure,pres_avemct,ptopm,2d,phy, +Time averaged middle cloud bottom pressure,pres_avemcb,pbotm,2d,phy, +Time averaged middle cloud top temperature,tmp_avemct,Ttopm,2d,phy, +Time averaged high cloud top pressure,pres_avehct,ptoph,2d,phy, +Time averaged high cloud bottom pressure,pres_avehcb,pboth,2d,phy, +Time averaged high cloud top temperature,tmp_avehct,Ttoph,2d,phy, +Boundary layer cloud cover,tcdc_avebndcl,pblcfr,2d,phy, +Cloud work function,cwork_aveclm,cldwork,2d,phy, +Accumulated total (base+surface) runoff,watr_acc,runoff,2d,phy, +Total water storage in aquifer,wa_acc,twa,2d,phy, +Accumulated evaporation of intercepted water,ecan_acc,tecan,2d,phy, +Accumulated plant transpiration,etran_acc,tetran,2d,phy, +Accumulated soil surface evaporation,edir_acc,tedir,2d,phy, +Shelter max temperature,t02max,maxtshltr,2d,phy,not GFS +Shelter max temperature,tmax_max2m,maxtshltr,2d,phy,GFS only +Shelter min temperature,t02min,mintshltr,2d,phy,not GFS +Shelter min temperature,tmin_min2m,mintshltr,2d,phy,GFS only +Shelter max rh,rh02max,maxrhshltr,2d,phy, +Shelter min rh,rh02min,minrhshltr,2d,phy, +Shelter max specific humidity,spfhmax_max2m,maxqshltr,2d,phy, +Shelter min specific humidity,spfhmin_min2m,minqshltr,2d,phy, +Ice thickness,icetk,dzice,2d,phy, +Wilting point,wilt,smcwlt,2d,phy, +Sunshine duration,sunsd_acc,suntime,2d,phy, +Field capacity,fldcp,fieldcapa,2d,phy, +Time averaged surface visible beam downward solar flux,vbdsf_ave,avisbeamswin,2d,phy, +Time averaged surface visible diffuse downward solar flux,vddsf_ave,avisdiffswin,2d,phy, +Time averaged surface near ir beam downward solar flux,nbdsf_ave,airbeamswin,2d,phy, +Time averaged surface near ir diffuse downward solar flux,nddsf_ave,airdiffswin,2d,phy, +Time averaged surface clear sky outgoing lw,csulf,alwoutc,2d,phy, +Time averaged toa clear sky outgoing lw,csulftoa,alwtoac,2d,phy, +Time averaged surface clear sky outgoing sw,csusf,aswoutc,2d,phy, +Time averaged toa clear sky outgoing sw,csusftoa,aswtoac,2d,phy, +Time averaged surface clear sky incoming lw,csdlf,alwinc,2d,phy, +Time averaged surface clear sky incoming sw,csdsf,aswinc,2d,phy, +Storm runoff,ssrun_acc,SSROFF,2d,phy, +Direct soil evaporation,evbs_ave,avgedir,2d,phy, +Canopy water evaporation,evcw_ave,avgecan,2d,phy, +Averaged precipitation advected heat flux,pah_ave,paha,2d,phy, +Instantaneous precipitation advected heat flux,pahi,pahi,2d,phy, +Plant transpiration,trans_ave,avgetrans,2d,phy, +Snow sublimation,sbsno_ave,avgesnow,2d,phy, +Total soil moisture,soilm,smstot,2d,phy, +Snow phase change heat flux,snohf,snopcx,2d,phy, +Precipitable water,pwat,pwat,2d,phy, +AQF chemical species,aalk1j,aalk1j,3d,dyn,aqfcmaq_on = True +,aalk2j,aalk2j,3d,dyn,aqfcmaq_on = True +,abnz1j,abnz1j,3d,dyn,aqfcmaq_on = True +,abnz2j,abnz2j,3d,dyn,aqfcmaq_on = True +,abnz3j,abnz3j,3d,dyn,aqfcmaq_on = True +,acaj,acaj,3d,dyn,aqfcmaq_on = True +,acet,acet,3d,dyn,aqfcmaq_on = True +,acli,acli,3d,dyn,aqfcmaq_on = True +,aclj,aclj,3d,dyn,aqfcmaq_on = True +,aclk,aclk,3d,dyn,aqfcmaq_on = True +,acors,acors,3d,dyn,aqfcmaq_on = True +,acro_primary,acro_primary,3d,dyn,aqfcmaq_on = True +,acrolein,acrolein,3d,dyn,aqfcmaq_on = True +,aeci,aeci,3d,dyn,aqfcmaq_on = True +,aecj,aecj,3d,dyn,aqfcmaq_on = True +,afej,afej,3d,dyn,aqfcmaq_on = True +,aglyj,aglyj,3d,dyn,aqfcmaq_on = True +,ah2oi,ah2oi,3d,dyn,aqfcmaq_on = True +,ah2oj,ah2oj,3d,dyn,aqfcmaq_on = True +,ah2ok,ah2ok,3d,dyn,aqfcmaq_on = True +,ah3opi,ah3opi,3d,dyn,aqfcmaq_on = True +,ah3opj,ah3opj,3d,dyn,aqfcmaq_on = True +,ah3opk,ah3opk,3d,dyn,aqfcmaq_on = True +,aiso1j,aiso1j,3d,dyn,aqfcmaq_on = True +,aiso2j,aiso2j,3d,dyn,aqfcmaq_on = True +,aiso3j,aiso3j,3d,dyn,aqfcmaq_on = True +,aivpo1j,aivpo1j,3d,dyn,aqfcmaq_on = True +,akj,akj,3d,dyn,aqfcmaq_on = True +,ald2,ald2,3d,dyn,aqfcmaq_on = True +,ald2_primary,ald2_primary,3d,dyn,aqfcmaq_on = True +,aldx,aldx,3d,dyn,aqfcmaq_on = True +,alvoo1i,alvoo1i,3d,dyn,aqfcmaq_on = True +,alvoo1j,alvoo1j,3d,dyn,aqfcmaq_on = True +,alvoo2i,alvoo2i,3d,dyn,aqfcmaq_on = True +,alvoo2j,alvoo2j,3d,dyn,aqfcmaq_on = True +,alvpo1i,alvpo1i,3d,dyn,aqfcmaq_on = True +,alvpo1j,alvpo1j,3d,dyn,aqfcmaq_on = True +,amgj,amgj,3d,dyn,aqfcmaq_on = True +,amnj,amnj,3d,dyn,aqfcmaq_on = True +,anai,anai,3d,dyn,aqfcmaq_on = True +,anaj,anaj,3d,dyn,aqfcmaq_on = True +,anh4i,anh4i,3d,dyn,aqfcmaq_on = True +,anh4j,anh4j,3d,dyn,aqfcmaq_on = True +,anh4k,anh4k,3d,dyn,aqfcmaq_on = True +,ano3i,ano3i,3d,dyn,aqfcmaq_on = True +,ano3j,ano3j,3d,dyn,aqfcmaq_on = True +,ano3k,ano3k,3d,dyn,aqfcmaq_on = True +,aolgaj,aolgaj,3d,dyn,aqfcmaq_on = True +,aolgbj,aolgbj,3d,dyn,aqfcmaq_on = True +,aorgcj,aorgcj,3d,dyn,aqfcmaq_on = True +,aothri,aothri,3d,dyn,aqfcmaq_on = True +,aothrj,aothrj,3d,dyn,aqfcmaq_on = True +,apah1j,apah1j,3d,dyn,aqfcmaq_on = True +,apah2j,apah2j,3d,dyn,aqfcmaq_on = True +,apah3j,apah3j,3d,dyn,aqfcmaq_on = True +,apcsoj,apcsoj,3d,dyn,aqfcmaq_on = True +,aseacat,aseacat,3d,dyn,aqfcmaq_on = True +,asij,asij,3d,dyn,aqfcmaq_on = True +,aso4i,aso4i,3d,dyn,aqfcmaq_on = True +,aso4j,aso4j,3d,dyn,aqfcmaq_on = True +,aso4k,aso4k,3d,dyn,aqfcmaq_on = True +,asoil,asoil,3d,dyn,aqfcmaq_on = True +,asqtj,asqtj,3d,dyn,aqfcmaq_on = True +,asvoo1i,asvoo1i,3d,dyn,aqfcmaq_on = True +,asvoo1j,asvoo1j,3d,dyn,aqfcmaq_on = True +,asvoo2i,asvoo2i,3d,dyn,aqfcmaq_on = True +,asvoo2j,asvoo2j,3d,dyn,aqfcmaq_on = True +,asvoo3j,asvoo3j,3d,dyn,aqfcmaq_on = True +,asvpo1i,asvpo1i,3d,dyn,aqfcmaq_on = True +,asvpo1j,asvpo1j,3d,dyn,aqfcmaq_on = True +,asvpo2i,asvpo2i,3d,dyn,aqfcmaq_on = True +,asvpo2j,asvpo2j,3d,dyn,aqfcmaq_on = True +,asvpo3j,asvpo3j,3d,dyn,aqfcmaq_on = True +,atij,atij,3d,dyn,aqfcmaq_on = True +,atol1j,atol1j,3d,dyn,aqfcmaq_on = True +,atol2j,atol2j,3d,dyn,aqfcmaq_on = True +,atol3j,atol3j,3d,dyn,aqfcmaq_on = True +,atrp1j,atrp1j,3d,dyn,aqfcmaq_on = True +,atrp2j,atrp2j,3d,dyn,aqfcmaq_on = True +,axyl1j,axyl1j,3d,dyn,aqfcmaq_on = True +,axyl2j,axyl2j,3d,dyn,aqfcmaq_on = True +,axyl3j,axyl3j,3d,dyn,aqfcmaq_on = True +,pm25ac,pm25ac,3d,dyn,aqfcmaq_on = True +,pm25at,pm25at,3d,dyn,aqfcmaq_on = True +,pm25co,pm25co,3d,dyn,aqfcmaq_on = True +Instantaneous aod550 optical depth,aod550,aod550,2d,phy,rdaod = True +,du_aod550,du_aod550,2d,phy,rdaod = True +,ss_aod550,ss_aod550,2d,phy,rdaod = True +,su_aod550,su_aod550,2d,phy,rdaod = True +,oc_aod550,oc_aod550,2d,phy,rdaod = True +,bc_aod550,bc_aod550,2d,phy,rdaod = True diff --git a/docs/UFS_unified_variables_table.rst b/docs/UFS_unified_variables_table.rst new file mode 100644 index 000000000..91294e36e --- /dev/null +++ b/docs/UFS_unified_variables_table.rst @@ -0,0 +1,13 @@ +******************************** +Unified Model Variables from UFS +******************************** + +Unified model variables read by UPP (column 1), the name of the variable in the model NetCDF file (column 2), +corresponding UPP internal name that the variable is read in as (column 3), variable dimension (column 4), +whether the variable resides in the dyn (atm) or phy (sfc) NetCDF file, and relevant notes such as +dependencies (column 5). + +.. csv-table:: + :file: UFS_unified_variables_table.csv + :widths: 25, 15, 15, 10, 15, 20 + :header-rows: 1 diff --git a/jobs/JGLOBAL_ATMOS_NCEPPOST b/jobs/JGLOBAL_ATMOS_NCEPPOST index 75da4d5cc..45adca8e5 100755 --- a/jobs/JGLOBAL_ATMOS_NCEPPOST +++ b/jobs/JGLOBAL_ATMOS_NCEPPOST @@ -65,9 +65,6 @@ export g2tmpl_ver=${g2tmpl_ver:-v1.5.0} export CDATE=${CDATE:-${PDY}${cyc}} export CDUMP=${CDUMP:-${RUN:-"gfs"}} export COMPONENT=${COMPONENT:-atmos} -if [ $RUN_ENVIR = "nco" ]; then - export ROTDIR=${COMROOT:?}/$NET/$envir -fi ############################################## @@ -77,17 +74,12 @@ export APRUNP=${APRUN:-$APRUN_NP} export RERUN=${RERUN:-NO} export HOMECRTM=${HOMECRTM:-${NWROOT}/lib/crtm/${crtm_ver}} export FIXCRTM=${CRTM_FIX:-${HOMECRTM}/fix} -#export FIXCRTM=${FIXCRTM:-${NWROOThps}/hwrf.${hwrf_ver}/fix/hwrf-crtm-2.0.6} export PARMpost=${PARMpost:-$HOMEgfs/parm/post} export INLINE_POST=${WRITE_DOPOST:-".false."} -if [ $RUN_ENVIR = "nco" ]; then - export COMIN=${COMIN:-$ROTDIR/$RUN.$PDY/$cyc/$COMPONENT} - export COMOUT=${COMOUT:-$ROTDIR/$RUN.$PDY/$cyc/$COMPONENT} -else - export COMIN="$ROTDIR/$CDUMP.$PDY/$cyc/$COMPONENT" - export COMOUT="$ROTDIR/$CDUMP.$PDY/$cyc/$COMPONENT" -fi +export COMIN=${COMIN:-$ROTDIR/$RUN.$PDY/$cyc/$COMPONENT} +export COMOUT=${COMOUT:-$ROTDIR/$RUN.$PDY/$cyc/$COMPONENT} + [[ ! -d $COMOUT ]] && mkdir -m 775 -p $COMOUT if [ $RUN = gfs ];then @@ -128,7 +120,7 @@ export SLEEP_INT=5 # Run relevant exglobal script env msg="HAS BEGUN on `hostname`" -postmsg "$jlogfile" "$msg" +postmsg "$msg" $LOGSCRIPT @@ -148,7 +140,7 @@ if [ -e "$pgmout" ]; then fi msg="ENDED NORMALLY." -postmsg "$jlogfile" "$msg" +postmsg "$msg" ########################################## diff --git a/jobs/JGLOBAL_ATMOS_POST_MANAGER b/jobs/JGLOBAL_ATMOS_POST_MANAGER index 26b17bcd6..94c848627 100755 --- a/jobs/JGLOBAL_ATMOS_POST_MANAGER +++ b/jobs/JGLOBAL_ATMOS_POST_MANAGER @@ -89,9 +89,9 @@ export EXT_FCST=NO ########################################### export cycle=t${cyc}z setpdy.sh -. PDY +. ./PDY -export ROTDIR=${ROTDIR:-{COMROOT:?}/$NET/$envir} +export ROTDIR=${ROTDIR:-${COMROOT:?}/$NET/$envir} export COMIN=${COMIN:-$ROTDIR/$RUN.$PDY/$cyc/$COMPONENT} export COMOUT=${COMOUT:-$ROTDIR/$RUN.$PDY/$cyc/$COMPONENT} diff --git a/jobs/J_NCEPPOST b/jobs/J_NCEPPOST index 746b6babe..0e1c5070e 100755 --- a/jobs/J_NCEPPOST +++ b/jobs/J_NCEPPOST @@ -24,11 +24,6 @@ mkdir -p $DATA cd $DATA export KEEPDATA=${KEEPDATA:-NO} -#################################### -# File To Log Msgs -#################################### -export jlogfile=${jlogfile:-${COMROOT}/logs/jlogfiles/jlogfile.${job}.${pid}} - #################################### # Determine Job Output Name on System #################################### diff --git a/manage_externals/.dir_locals.el b/manage_externals/.dir_locals.el deleted file mode 100644 index a370490e9..000000000 --- a/manage_externals/.dir_locals.el +++ /dev/null @@ -1,12 +0,0 @@ -; -*- mode: Lisp -*- - -((python-mode - . ( - ;; fill the paragraph to 80 columns when using M-q - (fill-column . 80) - - ;; Use 4 spaces to indent in Python - (python-indent-offset . 4) - (indent-tabs-mode . nil) - ))) - diff --git a/manage_externals/.github/ISSUE_TEMPLATE.md b/manage_externals/.github/ISSUE_TEMPLATE.md deleted file mode 100644 index 8ecb2ae64..000000000 --- a/manage_externals/.github/ISSUE_TEMPLATE.md +++ /dev/null @@ -1,6 +0,0 @@ -### Summary of Issue: -### Expected behavior and actual behavior: -### Steps to reproduce the problem (should include model description file(s) or link to publi c repository): -### What is the changeset ID of the code, and the machine you are using: -### have you modified the code? If so, it must be committed and available for testing: -### Screen output or log file showing the error message and context: diff --git a/manage_externals/.github/PULL_REQUEST_TEMPLATE.md b/manage_externals/.github/PULL_REQUEST_TEMPLATE.md deleted file mode 100644 index b68b1fb5e..000000000 --- a/manage_externals/.github/PULL_REQUEST_TEMPLATE.md +++ /dev/null @@ -1,17 +0,0 @@ -[ 50 character, one line summary ] - -[ Description of the changes in this commit. It should be enough - information for someone not following this development to understand. - Lines should be wrapped at about 72 characters. ] - -User interface changes?: [ No/Yes ] -[ If yes, describe what changed, and steps taken to ensure backward compatibilty ] - -Fixes: [Github issue #s] And brief description of each issue. - -Testing: - test removed: - unit tests: - system tests: - manual testing: - diff --git a/manage_externals/.gitignore b/manage_externals/.gitignore deleted file mode 100644 index 411de5d96..000000000 --- a/manage_externals/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -# directories that are checked out by the tool -cime/ -cime_config/ -components/ - -# generated local files -*.log - -# editor files -*~ -*.bak - -# generated python files -*.pyc diff --git a/manage_externals/.travis.yml b/manage_externals/.travis.yml deleted file mode 100644 index b32f81bd2..000000000 --- a/manage_externals/.travis.yml +++ /dev/null @@ -1,32 +0,0 @@ -# NOTE(bja, 2017-11) travis-ci dosen't support python language builds -# on mac os. As a work around, we use built-in python on linux, and -# declare osx a 'generic' language, and create our own python env. - -language: python -os: linux -python: - - "2.7" - - "3.4" - - "3.5" - - "3.6" -matrix: - include: - - os: osx - language: generic - before_install: - # NOTE(bja, 2017-11) update is slow, 2.7.12 installed by default, good enough! - # - brew update - # - brew outdated python2 || brew upgrade python2 - - pip install virtualenv - - virtualenv env -p python2 - - source env/bin/activate -install: - - pip install -r test/requirements.txt -before_script: - - git --version -script: - - cd test; make test - - cd test; make lint -after_success: - - cd test; make coverage - - cd test; coveralls diff --git a/manage_externals/LICENSE.txt b/manage_externals/LICENSE.txt deleted file mode 100644 index 665ee03fb..000000000 --- a/manage_externals/LICENSE.txt +++ /dev/null @@ -1,34 +0,0 @@ -Copyright (c) 2017-2018, University Corporation for Atmospheric Research (UCAR) -All rights reserved. - -Developed by: - University Corporation for Atmospheric Research - National Center for Atmospheric Research - https://www2.cesm.ucar.edu/working-groups/sewg - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the "Software"), -to deal with the Software without restriction, including without limitation -the rights to use, copy, modify, merge, publish, distribute, sublicense, -and/or sell copies of the Software, and to permit persons to whom -the Software is furnished to do so, subject to the following conditions: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimers. - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimers in the documentation - and/or other materials provided with the distribution. - - Neither the names of [Name of Development Group, UCAR], - nor the names of its contributors may be used to endorse or promote - products derived from this Software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. diff --git a/manage_externals/README.md b/manage_externals/README.md deleted file mode 100644 index 15e45ffb7..000000000 --- a/manage_externals/README.md +++ /dev/null @@ -1,211 +0,0 @@ --- AUTOMATICALLY GENERATED FILE. DO NOT EDIT -- - -[![Build Status](https://travis-ci.org/ESMCI/manage_externals.svg?branch=master)](https://travis-ci.org/ESMCI/manage_externals)[![Coverage Status](https://coveralls.io/repos/github/ESMCI/manage_externals/badge.svg?branch=master)](https://coveralls.io/github/ESMCI/manage_externals?branch=master) -``` -usage: checkout_externals [-h] [-e [EXTERNALS]] [-o] [-S] [-v] [--backtrace] - [-d] [--no-logging] - -checkout_externals manages checking out groups of externals from revision -control based on a externals description file. By default only the -required externals are checkout out. - -Operations performed by manage_externals utilities are explicit and -data driven. checkout_externals will always make the working copy *exactly* -match what is in the externals file when modifying the working copy of -a repository. - -If checkout_externals isn't doing what you expected, double check the contents -of the externals description file. - -Running checkout_externals without the '--status' option will always attempt to -synchronize the working copy to exactly match the externals description. - -optional arguments: - -h, --help show this help message and exit - -e [EXTERNALS], --externals [EXTERNALS] - The externals description filename. Default: - Externals.cfg. - -o, --optional By default only the required externals are checked - out. This flag will also checkout the optional - externals. - -S, --status Output status of the repositories managed by - checkout_externals. By default only summary - information is provided. Use verbose output to see - details. - -v, --verbose Output additional information to the screen and log - file. This flag can be used up to two times, - increasing the verbosity level each time. - --backtrace DEVELOPER: show exception backtraces as extra - debugging output - -d, --debug DEVELOPER: output additional debugging information to - the screen and log file. - --no-logging DEVELOPER: disable logging. - -``` -NOTE: checkout_externals *MUST* be run from the root of the source tree it -is managing. For example, if you cloned a repository with: - - $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev - -Then the root of the source tree is /path/to/some-project-dev. If you -obtained a sub-project via a checkout of another project: - - $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev - -and you need to checkout the sub-project externals, then the root of the -source tree is /path/to/some-project-dev. Do *NOT* run checkout_externals -from within /path/to/some-project-dev/sub-project - -The root of the source tree will be referred to as `${SRC_ROOT}` below. - -# Supported workflows - - * Checkout all required components from the default externals - description file: - - $ cd ${SRC_ROOT} - $ ./manage_externals/checkout_externals - - * To update all required components to the current values in the - externals description file, re-run checkout_externals: - - $ cd ${SRC_ROOT} - $ ./manage_externals/checkout_externals - - If there are *any* modifications to *any* working copy according - to the git or svn 'status' command, checkout_externals - will not update any external repositories. Modifications - include: modified files, added files, removed files, or missing - files. - - To avoid this safety check, edit the externals description file - and comment out the modified external block. - - * Checkout all required components from a user specified externals - description file: - - $ cd ${SRC_ROOT} - $ ./manage_externals/checkout_externals --excernals my-externals.cfg - - * Status summary of the repositories managed by checkout_externals: - - $ cd ${SRC_ROOT} - $ ./manage_externals/checkout_externals --status - - ./cime - s ./components/cism - ./components/mosart - e-o ./components/rtm - M ./src/fates - e-o ./tools/PTCLM - - where: - * column one indicates the status of the repository in relation - to the externals description file. - * column two indicates whether the working copy has modified files. - * column three shows how the repository is managed, optional or required - - Column one will be one of these values: - * s : out-of-sync : repository is checked out at a different commit - compared with the externals description - * e : empty : directory does not exist - checkout_externals has not been run - * ? : unknown : directory exists but .git or .svn directories are missing - - Column two will be one of these values: - * M : Modified : modified, added, deleted or missing files - * : blank / space : clean - * - : dash : no meaningful state, for empty repositories - - Column three will be one of these values: - * o : optional : optionally repository - * : blank / space : required repository - - * Detailed git or svn status of the repositories managed by checkout_externals: - - $ cd ${SRC_ROOT} - $ ./manage_externals/checkout_externals --status --verbose - -# Externals description file - - The externals description contains a list of the external - repositories that are used and their version control locations. The - file format is the standard ini/cfg configuration file format. Each - external is defined by a section containing the component name in - square brackets: - - * name (string) : component name, e.g. [cime], [cism], etc. - - Each section has the following keyword-value pairs: - - * required (boolean) : whether the component is a required checkout, - 'true' or 'false'. - - * local_path (string) : component path *relative* to where - checkout_externals is called. - - * protoctol (string) : version control protocol that is used to - manage the component. Valid values are 'git', 'svn', - 'externals_only'. - - Switching an external between different protocols is not - supported, e.g. from svn to git. To switch protocols, you need to - manually move the old working copy to a new location. - - Note: 'externals_only' will only process the external's own - external description file without trying to manage a repository - for the component. This is used for retreiving externals for - standalone components like cam and clm. If the source root of the - externals_only component is the same as the main source root, then - the local path must be set to '.', the unix current working - directory, e. g. 'local_path = .' - - * repo_url (string) : URL for the repository location, examples: - * https://svn-ccsm-models.cgd.ucar.edu/glc - * git@github.com:esmci/cime.git - * /path/to/local/repository - * . - - NOTE: To operate on only the local clone and and ignore remote - repositories, set the url to '.' (the unix current path), - i.e. 'repo_url = .' . This can be used to checkout a local branch - instead of the upstream branch. - - If a repo url is determined to be a local path (not a network url) - then user expansion, e.g. ~/, and environment variable expansion, - e.g. $HOME or $REPO_ROOT, will be performed. - - Relative paths are difficult to get correct, especially for mixed - use repos. It is advised that local paths expand to absolute paths. - If relative paths are used, they should be relative to one level - above local_path. If local path is 'src/foo', the the relative url - should be relative to 'src'. - - * tag (string) : tag to checkout - - * hash (string) : the git hash to checkout. Only applies to git - repositories. - - * branch (string) : branch to checkout from the specified - repository. Specifying a branch on a remote repository means that - checkout_externals will checkout the version of the branch in the remote, - not the the version in the local repository (if it exists). - - Note: one and only one of tag, branch hash must be supplied. - - * externals (string) : used to make manage_externals aware of - sub-externals required by an external. This is a relative path to - the external's root directory. For example, the main externals - description has an external checkout out at 'src/useful_library'. - useful_library requires additional externals to be complete. - Those additional externals are managed from the source root by the - externals description file pointed 'useful_library/sub-xternals.cfg', - Then the main 'externals' field in the top level repo should point to - 'sub-externals.cfg'. - - * Lines begining with '#' or ';' are comments and will be ignored. - -# Obtaining this tool, reporting issues, etc. - - The master repository for manage_externals is - https://github.com/ESMCI/manage_externals. Any issues with this tool - should be reported there. diff --git a/manage_externals/README_FIRST b/manage_externals/README_FIRST deleted file mode 100644 index c8a47d780..000000000 --- a/manage_externals/README_FIRST +++ /dev/null @@ -1,54 +0,0 @@ -CESM is comprised of a number of different components that are -developed and managed independently. Each component may have -additional 'external' dependancies and optional parts that are also -developed and managed independently. - -The checkout_externals.py tool manages retreiving and updating the -components and their externals so you have a complete set of source -files for the model. - -checkout_externals.py relies on a model description file that -describes what components are needed, where to find them and where to -put them in the source tree. The default file is called "CESM.xml" -regardless of whether you are checking out CESM or a standalone -component. - -checkout_externals requires access to git and svn repositories that -require authentication. checkout_externals may pass through -authentication requests, but it will not cache them for you. For the -best and most robust user experience, you should have svn and git -working without password authentication. See: - - https://help.github.com/articles/connecting-to-github-with-ssh/ - - ?svn ref? - -NOTE: checkout_externals.py *MUST* be run from the root of the source -tree it is managing. For example, if you cloned CLM with: - - $ git clone git@github.com/ncar/clm clm-dev - -Then the root of the source tree is /path/to/cesm-dev. If you obtained -CLM via an svn checkout of CESM and you need to checkout the CLM -externals, then the root of the source tree for CLM is: - - /path/to/cesm-dev/components/clm - -The root of the source tree will be referred to as ${SRC_ROOT} below. - -To get started quickly, checkout all required components from the -default model description file: - - $ cd ${SRC_ROOT} - $ ./checkout_cesm/checkout_externals.py - -For additional information about using checkout model, please see: - - ${SRC_ROOT}/checkout_cesm/README - -or run: - - $ cd ${SRC_ROOT} - $ ./checkout_cesm/checkout_externals.py --help - - diff --git a/manage_externals/checkout_externals b/manage_externals/checkout_externals deleted file mode 100755 index a0698baef..000000000 --- a/manage_externals/checkout_externals +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/env python - -"""Main driver wrapper around the manic/checkout utility. - -Tool to assemble external respositories represented in an externals -description file. - -""" -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import sys -import traceback - -import manic - -if sys.hexversion < 0x02070000: - print(70 * '*') - print('ERROR: {0} requires python >= 2.7.x. '.format(sys.argv[0])) - print('It appears that you are running python {0}'.format( - '.'.join(str(x) for x in sys.version_info[0:3]))) - print(70 * '*') - sys.exit(1) - - -if __name__ == '__main__': - ARGS = manic.checkout.commandline_arguments() - try: - RET_STATUS, _ = manic.checkout.main(ARGS) - sys.exit(RET_STATUS) - except Exception as error: # pylint: disable=broad-except - manic.printlog(str(error)) - if ARGS.backtrace: - traceback.print_exc() - sys.exit(1) diff --git a/manage_externals/manic/__init__.py b/manage_externals/manic/__init__.py deleted file mode 100644 index 11badedd3..000000000 --- a/manage_externals/manic/__init__.py +++ /dev/null @@ -1,9 +0,0 @@ -"""Public API for the manage_externals library -""" - -from manic import checkout -from manic.utils import printlog - -__all__ = [ - 'checkout', 'printlog', -] diff --git a/manage_externals/manic/checkout.py b/manage_externals/manic/checkout.py deleted file mode 100755 index afd3a2788..000000000 --- a/manage_externals/manic/checkout.py +++ /dev/null @@ -1,409 +0,0 @@ -#!/usr/bin/env python - -""" -Tool to assemble repositories represented in a model-description file. - -If loaded as a module (e.g., in a component's buildcpp), it can be used -to check the validity of existing subdirectories and load missing sources. -""" -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import argparse -import logging -import os -import os.path -import sys - -from manic.externals_description import create_externals_description -from manic.externals_description import read_externals_description_file -from manic.externals_status import check_safe_to_update_repos -from manic.sourcetree import SourceTree -from manic.utils import printlog, fatal_error -from manic.global_constants import VERSION_SEPERATOR, LOG_FILE_NAME - -if sys.hexversion < 0x02070000: - print(70 * '*') - print('ERROR: {0} requires python >= 2.7.x. '.format(sys.argv[0])) - print('It appears that you are running python {0}'.format( - VERSION_SEPERATOR.join(str(x) for x in sys.version_info[0:3]))) - print(70 * '*') - sys.exit(1) - - -# --------------------------------------------------------------------- -# -# User input -# -# --------------------------------------------------------------------- -def commandline_arguments(args=None): - """Process the command line arguments - - Params: args - optional args. Should only be used during systems - testing. - - Returns: processed command line arguments - """ - description = ''' - -%(prog)s manages checking out groups of externals from revision -control based on an externals description file. By default only the -required externals are checkout out. - -Running %(prog)s without the '--status' option will always attempt to -synchronize the working copy to exactly match the externals description. -''' - - epilog = ''' -``` -NOTE: %(prog)s *MUST* be run from the root of the source tree it -is managing. For example, if you cloned a repository with: - - $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev - -Then the root of the source tree is /path/to/some-project-dev. If you -obtained a sub-project via a checkout of another project: - - $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev - -and you need to checkout the sub-project externals, then the root of the -source tree remains /path/to/some-project-dev. Do *NOT* run %(prog)s -from within /path/to/some-project-dev/sub-project - -The root of the source tree will be referred to as `${SRC_ROOT}` below. - - -# Supported workflows - - * Checkout all required components from the default externals - description file: - - $ cd ${SRC_ROOT} - $ ./manage_externals/%(prog)s - - * To update all required components to the current values in the - externals description file, re-run %(prog)s: - - $ cd ${SRC_ROOT} - $ ./manage_externals/%(prog)s - - If there are *any* modifications to *any* working copy according - to the git or svn 'status' command, %(prog)s - will not update any external repositories. Modifications - include: modified files, added files, removed files, or missing - files. - - To avoid this safety check, edit the externals description file - and comment out the modified external block. - - * Checkout all required components from a user specified externals - description file: - - $ cd ${SRC_ROOT} - $ ./manage_externals/%(prog)s --externals my-externals.cfg - - * Status summary of the repositories managed by %(prog)s: - - $ cd ${SRC_ROOT} - $ ./manage_externals/%(prog)s --status - - ./cime - s ./components/cism - ./components/mosart - e-o ./components/rtm - M ./src/fates - e-o ./tools/PTCLM - - - where: - * column one indicates the status of the repository in relation - to the externals description file. - * column two indicates whether the working copy has modified files. - * column three shows how the repository is managed, optional or required - - Column one will be one of these values: - * s : out-of-sync : repository is checked out at a different commit - compared with the externals description - * e : empty : directory does not exist - %(prog)s has not been run - * ? : unknown : directory exists but .git or .svn directories are missing - - Column two will be one of these values: - * M : Modified : modified, added, deleted or missing files - * : blank / space : clean - * - : dash : no meaningful state, for empty repositories - - Column three will be one of these values: - * o : optional : optionally repository - * : blank / space : required repository - - * Detailed git or svn status of the repositories managed by %(prog)s: - - $ cd ${SRC_ROOT} - $ ./manage_externals/%(prog)s --status --verbose - -# Externals description file - - The externals description contains a list of the external - repositories that are used and their version control locations. The - file format is the standard ini/cfg configuration file format. Each - external is defined by a section containing the component name in - square brackets: - - * name (string) : component name, e.g. [cime], [cism], etc. - - Each section has the following keyword-value pairs: - - * required (boolean) : whether the component is a required checkout, - 'true' or 'false'. - - * local_path (string) : component path *relative* to where - %(prog)s is called. - - * protoctol (string) : version control protocol that is used to - manage the component. Valid values are 'git', 'svn', - 'externals_only'. - - Switching an external between different protocols is not - supported, e.g. from svn to git. To switch protocols, you need to - manually move the old working copy to a new location. - - Note: 'externals_only' will only process the external's own - external description file without trying to manage a repository - for the component. This is used for retrieving externals for - standalone components like cam and ctsm which also serve as - sub-components within a larger project. If the source root of the - externals_only component is the same as the main source root, then - the local path must be set to '.', the unix current working - directory, e. g. 'local_path = .' - - * repo_url (string) : URL for the repository location, examples: - * https://svn-ccsm-models.cgd.ucar.edu/glc - * git@github.com:esmci/cime.git - * /path/to/local/repository - * . - - NOTE: To operate on only the local clone and and ignore remote - repositories, set the url to '.' (the unix current path), - i.e. 'repo_url = .' . This can be used to checkout a local branch - instead of the upstream branch. - - If a repo url is determined to be a local path (not a network url) - then user expansion, e.g. ~/, and environment variable expansion, - e.g. $HOME or $REPO_ROOT, will be performed. - - Relative paths are difficult to get correct, especially for mixed - use repos. It is advised that local paths expand to absolute paths. - If relative paths are used, they should be relative to one level - above local_path. If local path is 'src/foo', the the relative url - should be relative to 'src'. - - * tag (string) : tag to checkout - - * hash (string) : the git hash to checkout. Only applies to git - repositories. - - * branch (string) : branch to checkout from the specified - repository. Specifying a branch on a remote repository means that - %(prog)s will checkout the version of the branch in the remote, - not the the version in the local repository (if it exists). - - Note: one and only one of tag, branch hash must be supplied. - - * externals (string) : used to make manage_externals aware of - sub-externals required by an external. This is a relative path to - the external's root directory. For example, if LIBX is often used - as a sub-external, it might have an externals file (for its - externals) called Externals_LIBX.cfg. To use libx as a standalone - checkout, it would have another file, Externals.cfg with the - following entry: - - [ libx ] - local_path = . - protocol = externals_only - externals = Externals_LIBX.cfg - required = True - - Now, %(prog)s will process Externals.cfg and also process - Externals_LIBX.cfg as if it was a sub-external. - - * Lines beginning with '#' or ';' are comments and will be ignored. - -# Obtaining this tool, reporting issues, etc. - - The master repository for manage_externals is - https://github.com/ESMCI/manage_externals. Any issues with this tool - should be reported there. - -# Troubleshooting - -Operations performed by manage_externals utilities are explicit and -data driven. %(prog)s will always attempt to make the working copy -*exactly* match what is in the externals file when modifying the -working copy of a repository. - -If %(prog)s is not doing what you expected, double check the contents -of the externals description file or examine the output of -./manage_externals/%(prog)s --status - -''' - - parser = argparse.ArgumentParser( - description=description, epilog=epilog, - formatter_class=argparse.RawDescriptionHelpFormatter) - - # - # user options - # - parser.add_argument("components", nargs="*", - help="Specific component(s) to checkout. By default, " - "all required externals are checked out.") - - parser.add_argument('-e', '--externals', nargs='?', - default='Externals.cfg', - help='The externals description filename. ' - 'Default: %(default)s.') - - parser.add_argument('-o', '--optional', action='store_true', default=False, - help='By default only the required externals ' - 'are checked out. This flag will also checkout the ' - 'optional externals.') - - parser.add_argument('-S', '--status', action='store_true', default=False, - help='Output the status of the repositories managed by ' - '%(prog)s. By default only summary information ' - 'is provided. Use the verbose option to see details.') - - parser.add_argument('-v', '--verbose', action='count', default=0, - help='Output additional information to ' - 'the screen and log file. This flag can be ' - 'used up to two times, increasing the ' - 'verbosity level each time.') - - parser.add_argument('--svn-ignore-ancestry', action='store_true', default=False, - help='By default, subversion will abort if a component is ' - 'already checked out and there is no common ancestry with ' - 'the new URL. This flag passes the "--ignore-ancestry" flag ' - 'to the svn switch call. (This is not recommended unless ' - 'you are sure about what you are doing.)') - - # - # developer options - # - parser.add_argument('--backtrace', action='store_true', - help='DEVELOPER: show exception backtraces as extra ' - 'debugging output') - - parser.add_argument('-d', '--debug', action='store_true', default=False, - help='DEVELOPER: output additional debugging ' - 'information to the screen and log file.') - - logging_group = parser.add_mutually_exclusive_group() - - logging_group.add_argument('--logging', dest='do_logging', - action='store_true', - help='DEVELOPER: enable logging.') - logging_group.add_argument('--no-logging', dest='do_logging', - action='store_false', default=False, - help='DEVELOPER: disable logging ' - '(this is the default)') - - if args: - options = parser.parse_args(args) - else: - options = parser.parse_args() - return options - - -# --------------------------------------------------------------------- -# -# main -# -# --------------------------------------------------------------------- -def main(args): - """ - Function to call when module is called from the command line. - Parse externals file and load required repositories or all repositories if - the --all option is passed. - - Returns a tuple (overall_status, tree_status). overall_status is 0 - on success, non-zero on failure. tree_status gives the full status - *before* executing the checkout command - i.e., the status that it - used to determine if it's safe to proceed with the checkout. - """ - if args.do_logging: - logging.basicConfig(filename=LOG_FILE_NAME, - format='%(levelname)s : %(asctime)s : %(message)s', - datefmt='%Y-%m-%d %H:%M:%S', - level=logging.DEBUG) - - program_name = os.path.basename(sys.argv[0]) - logging.info('Beginning of %s', program_name) - - load_all = False - if args.optional: - load_all = True - - root_dir = os.path.abspath(os.getcwd()) - external_data = read_externals_description_file(root_dir, args.externals) - external = create_externals_description( - external_data, components=args.components) - - for comp in args.components: - if comp not in external.keys(): - fatal_error( - "No component {} found in {}".format( - comp, args.externals)) - - source_tree = SourceTree(root_dir, external, svn_ignore_ancestry=args.svn_ignore_ancestry) - printlog('Checking status of externals: ', end='') - tree_status = source_tree.status() - printlog('') - - if args.status: - # user requested status-only - for comp in sorted(tree_status.keys()): - tree_status[comp].log_status_message(args.verbose) - else: - # checkout / update the external repositories. - safe_to_update = check_safe_to_update_repos(tree_status) - if not safe_to_update: - # print status - for comp in sorted(tree_status.keys()): - tree_status[comp].log_status_message(args.verbose) - # exit gracefully - msg = """The external repositories labeled with 'M' above are not in a clean state. - -The following are two options for how to proceed: - -(1) Go into each external that is not in a clean state and issue either - an 'svn status' or a 'git status' command. Either revert or commit - your changes so that all externals are in a clean state. (Note, - though, that it is okay to have untracked files in your working - directory.) Then rerun {program_name}. - -(2) Alternatively, you do not have to rely on {program_name}. Instead, you - can manually update out-of-sync externals (labeled with 's' above) - as described in the configuration file {config_file}. - - -The external repositories labeled with '?' above are not under version -control using the expected protocol. If you are sure you want to switch -protocols, and you don't have any work you need to save from this -directory, then run "rm -rf [directory]" before re-running the -checkout_externals tool. -""".format(program_name=program_name, config_file=args.externals) - - printlog('-' * 70) - printlog(msg) - printlog('-' * 70) - else: - if not args.components: - source_tree.checkout(args.verbose, load_all) - for comp in args.components: - source_tree.checkout(args.verbose, load_all, load_comp=comp) - printlog('') - - logging.info('%s completed without exceptions.', program_name) - # NOTE(bja, 2017-11) tree status is used by the systems tests - return 0, tree_status diff --git a/manage_externals/manic/externals_description.py b/manage_externals/manic/externals_description.py deleted file mode 100644 index 3cebf525b..000000000 --- a/manage_externals/manic/externals_description.py +++ /dev/null @@ -1,790 +0,0 @@ -#!/usr/bin/env python - -"""Model description - -Model description is the representation of the various externals -included in the model. It processes in input data structure, and -converts it into a standard interface that is used by the rest of the -system. - -To maintain backward compatibility, externals description files should -follow semantic versioning rules, http://semver.org/ - - - -""" -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import logging -import os -import os.path -import re - -# ConfigParser in python2 was renamed to configparser in python3. -# In python2, ConfigParser returns byte strings, str, instead of unicode. -# We need unicode to be compatible with xml and json parser and python3. -try: - # python2 - from ConfigParser import SafeConfigParser as config_parser - from ConfigParser import MissingSectionHeaderError - from ConfigParser import NoSectionError, NoOptionError - - USE_PYTHON2 = True - - def config_string_cleaner(text): - """convert strings into unicode - """ - return text.decode('utf-8') -except ImportError: - # python3 - from configparser import ConfigParser as config_parser - from configparser import MissingSectionHeaderError - from configparser import NoSectionError, NoOptionError - - USE_PYTHON2 = False - - def config_string_cleaner(text): - """Python3 already uses unicode strings, so just return the string - without modification. - - """ - return text - -from .utils import printlog, fatal_error, str_to_bool, expand_local_url -from .utils import execute_subprocess -from .global_constants import EMPTY_STR, PPRINTER, VERSION_SEPERATOR - -# -# Globals -# -DESCRIPTION_SECTION = 'externals_description' -VERSION_ITEM = 'schema_version' - - -def read_externals_description_file(root_dir, file_name): - """Read a file containing an externals description and - create its internal representation. - - """ - root_dir = os.path.abspath(root_dir) - msg = 'In directory : {0}'.format(root_dir) - logging.info(msg) - printlog('Processing externals description file : {0}'.format(file_name)) - - file_path = os.path.join(root_dir, file_name) - if not os.path.exists(file_name): - if file_name.lower() == "none": - msg = ('INTERNAL ERROR: Attempt to read externals file ' - 'from {0} when not configured'.format(file_path)) - else: - msg = ('ERROR: Model description file, "{0}", does not ' - 'exist at path:\n {1}\nDid you run from the root of ' - 'the source tree?'.format(file_name, file_path)) - - fatal_error(msg) - - externals_description = None - if file_name == ExternalsDescription.GIT_SUBMODULES_FILENAME: - externals_description = read_gitmodules_file(root_dir, file_name) - else: - try: - config = config_parser() - config.read(file_path) - externals_description = config - except MissingSectionHeaderError: - # not a cfg file - pass - - if externals_description is None: - msg = 'Unknown file format!' - fatal_error(msg) - - return externals_description - -class LstripReader(object): - "LstripReader formats .gitmodules files to be acceptable for configparser" - def __init__(self, filename): - with open(filename, 'r') as infile: - lines = infile.readlines() - self._lines = list() - self._num_lines = len(lines) - self._index = 0 - for line in lines: - self._lines.append(line.lstrip()) - - def readlines(self): - """Return all the lines from this object's file""" - return self._lines - - def readline(self, size=-1): - """Format and return the next line or raise StopIteration""" - try: - line = self.next() - except StopIteration: - line = '' - - if (size > 0) and (len(line) < size): - return line[0:size] - - return line - - def __iter__(self): - """Begin an iteration""" - self._index = 0 - return self - - def next(self): - """Return the next line or raise StopIteration""" - if self._index >= self._num_lines: - raise StopIteration - - self._index = self._index + 1 - return self._lines[self._index - 1] - - def __next__(self): - return self.next() - -def git_submodule_status(repo_dir): - """Run the git submodule status command to obtain submodule hashes. - """ - # This function is here instead of GitRepository to avoid a dependency loop - cwd = os.getcwd() - os.chdir(repo_dir) - cmd = ['git', 'submodule', 'status'] - git_output = execute_subprocess(cmd, output_to_caller=True) - submodules = {} - submods = git_output.split('\n') - for submod in submods: - if submod: - status = submod[0] - items = submod[1:].split(' ') - if len(items) > 2: - tag = items[2] - else: - tag = None - - submodules[items[1]] = {'hash':items[0], 'status':status, 'tag':tag} - - os.chdir(cwd) - return submodules - -def parse_submodules_desc_section(section_items, file_path): - """Find the path and url for this submodule description""" - path = None - url = None - for item in section_items: - name = item[0].strip().lower() - if name == 'path': - path = item[1].strip() - elif name == 'url': - url = item[1].strip() - else: - msg = 'WARNING: Ignoring unknown {} property, in {}' - msg = msg.format(item[0], file_path) # fool pylint - logging.warning(msg) - - return path, url - -def read_gitmodules_file(root_dir, file_name): - # pylint: disable=deprecated-method - # Disabling this check because the method is only used for python2 - """Read a .gitmodules file and convert it to be compatible with an - externals description. - """ - root_dir = os.path.abspath(root_dir) - msg = 'In directory : {0}'.format(root_dir) - logging.info(msg) - printlog('Processing submodules description file : {0}'.format(file_name)) - - file_path = os.path.join(root_dir, file_name) - if not os.path.exists(file_name): - msg = ('ERROR: submodules description file, "{0}", does not ' - 'exist at path:\n {1}'.format(file_name, file_path)) - fatal_error(msg) - - submodules_description = None - externals_description = None - try: - config = config_parser() - if USE_PYTHON2: - config.readfp(LstripReader(file_path), filename=file_name) - else: - config.read_file(LstripReader(file_path), source=file_name) - - submodules_description = config - except MissingSectionHeaderError: - # not a cfg file - pass - - if submodules_description is None: - msg = 'Unknown file format!' - fatal_error(msg) - else: - # Convert the submodules description to an externals description - externals_description = config_parser() - # We need to grab all the commit hashes for this repo - submods = git_submodule_status(root_dir) - for section in submodules_description.sections(): - if section[0:9] == 'submodule': - sec_name = section[9:].strip(' "') - externals_description.add_section(sec_name) - section_items = submodules_description.items(section) - path, url = parse_submodules_desc_section(section_items, - file_path) - - if path is None: - msg = 'Submodule {} missing path'.format(sec_name) - fatal_error(msg) - - if url is None: - msg = 'Submodule {} missing url'.format(sec_name) - fatal_error(msg) - - externals_description.set(sec_name, - ExternalsDescription.PATH, path) - externals_description.set(sec_name, - ExternalsDescription.PROTOCOL, 'git') - externals_description.set(sec_name, - ExternalsDescription.REPO_URL, url) - externals_description.set(sec_name, - ExternalsDescription.REQUIRED, 'True') - git_hash = submods[sec_name]['hash'] - externals_description.set(sec_name, - ExternalsDescription.HASH, git_hash) - - # Required items - externals_description.add_section(DESCRIPTION_SECTION) - externals_description.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.0.0') - - return externals_description - -def create_externals_description( - model_data, model_format='cfg', components=None, parent_repo=None): - """Create the a externals description object from the provided data - """ - externals_description = None - if model_format == 'dict': - externals_description = ExternalsDescriptionDict( - model_data, components=components) - elif model_format == 'cfg': - major, _, _ = get_cfg_schema_version(model_data) - if major == 1: - externals_description = ExternalsDescriptionConfigV1( - model_data, components=components, parent_repo=parent_repo) - else: - msg = ('Externals description file has unsupported schema ' - 'version "{0}".'.format(major)) - fatal_error(msg) - else: - msg = 'Unknown model data format "{0}"'.format(model_format) - fatal_error(msg) - return externals_description - - -def get_cfg_schema_version(model_cfg): - """Extract the major, minor, patch version of the config file schema - - Params: - model_cfg - config parser object containing the externas description data - - Returns: - major = integer major version - minor = integer minor version - patch = integer patch version - """ - semver_str = '' - try: - semver_str = model_cfg.get(DESCRIPTION_SECTION, VERSION_ITEM) - except (NoSectionError, NoOptionError): - msg = ('externals description file must have the required ' - 'section: "{0}" and item "{1}"'.format(DESCRIPTION_SECTION, - VERSION_ITEM)) - fatal_error(msg) - - # NOTE(bja, 2017-11) Assume we don't care about the - # build/pre-release metadata for now! - version_list = re.split(r'[-+]', semver_str) - version_str = version_list[0] - version = version_str.split(VERSION_SEPERATOR) - try: - major = int(version[0].strip()) - minor = int(version[1].strip()) - patch = int(version[2].strip()) - except ValueError: - msg = ('Config file schema version must have integer digits for ' - 'major, minor and patch versions. ' - 'Received "{0}"'.format(version_str)) - fatal_error(msg) - return major, minor, patch - - -class ExternalsDescription(dict): - """Base externals description class that is independent of the user input - format. Different input formats can all be converted to this - representation to provide a consistent represtentation for the - rest of the objects in the system. - - NOTE(bja, 2018-03): do NOT define _schema_major etc at the class - level in the base class. The nested/recursive nature of externals - means different schema versions may be present in a single run! - - All inheriting classes must overwrite: - self._schema_major and self._input_major - self._schema_minor and self._input_minor - self._schema_patch and self._input_patch - - where _schema_x is the supported schema, _input_x is the user - input value. - - """ - # keywords defining the interface into the externals description data - EXTERNALS = 'externals' - BRANCH = 'branch' - SUBMODULE = 'from_submodule' - HASH = 'hash' - NAME = 'name' - PATH = 'local_path' - PROTOCOL = 'protocol' - REPO = 'repo' - REPO_URL = 'repo_url' - REQUIRED = 'required' - TAG = 'tag' - - PROTOCOL_EXTERNALS_ONLY = 'externals_only' - PROTOCOL_GIT = 'git' - PROTOCOL_SVN = 'svn' - GIT_SUBMODULES_FILENAME = '.gitmodules' - KNOWN_PRROTOCOLS = [PROTOCOL_GIT, PROTOCOL_SVN, PROTOCOL_EXTERNALS_ONLY] - - # v1 xml keywords - _V1_TREE_PATH = 'TREE_PATH' - _V1_ROOT = 'ROOT' - _V1_TAG = 'TAG' - _V1_BRANCH = 'BRANCH' - _V1_REQ_SOURCE = 'REQ_SOURCE' - - _source_schema = {REQUIRED: True, - PATH: 'string', - EXTERNALS: 'string', - SUBMODULE : True, - REPO: {PROTOCOL: 'string', - REPO_URL: 'string', - TAG: 'string', - BRANCH: 'string', - HASH: 'string', - } - } - - def __init__(self, parent_repo=None): - """Convert the xml into a standardized dict that can be used to - construct the source objects - - """ - dict.__init__(self) - - self._schema_major = None - self._schema_minor = None - self._schema_patch = None - self._input_major = None - self._input_minor = None - self._input_patch = None - self._parent_repo = parent_repo - - def _verify_schema_version(self): - """Use semantic versioning rules to verify we can process this schema. - - """ - known = '{0}.{1}.{2}'.format(self._schema_major, - self._schema_minor, - self._schema_patch) - received = '{0}.{1}.{2}'.format(self._input_major, - self._input_minor, - self._input_patch) - - if self._input_major != self._schema_major: - # should never get here, the factory should handle this correctly! - msg = ('DEV_ERROR: version "{0}" parser received ' - 'version "{1}" input.'.format(known, received)) - fatal_error(msg) - - if self._input_minor > self._schema_minor: - msg = ('Incompatible schema version:\n' - ' User supplied schema version "{0}" is too new."\n' - ' Can only process version "{1}" files and ' - 'older.'.format(received, known)) - fatal_error(msg) - - if self._input_patch > self._schema_patch: - # NOTE(bja, 2018-03) ignoring for now... Not clear what - # conditions the test is needed. - pass - - def _check_user_input(self): - """Run a series of checks to attempt to validate the user input and - detect errors as soon as possible. - - NOTE(bja, 2018-03) These checks are called *after* the file is - read. That means the schema check can not occur here. - - Note: the order is important. check_optional will create - optional with null data. run check_data first to ensure - required data was provided correctly by the user. - - """ - self._check_data() - self._check_optional() - self._validate() - - def _check_data(self): - # pylint: disable=too-many-branches,too-many-statements - """Check user supplied data is valid where possible. - """ - for ext_name in self.keys(): - if (self[ext_name][self.REPO][self.PROTOCOL] - not in self.KNOWN_PRROTOCOLS): - msg = 'Unknown repository protocol "{0}" in "{1}".'.format( - self[ext_name][self.REPO][self.PROTOCOL], ext_name) - fatal_error(msg) - - if (self[ext_name][self.REPO][self.PROTOCOL] == - self.PROTOCOL_SVN): - if self.HASH in self[ext_name][self.REPO]: - msg = ('In repo description for "{0}". svn repositories ' - 'may not include the "hash" keyword.'.format( - ext_name)) - fatal_error(msg) - - if ((self[ext_name][self.REPO][self.PROTOCOL] != self.PROTOCOL_GIT) - and (self.SUBMODULE in self[ext_name])): - msg = ('self.SUBMODULE is only supported with {0} protocol, ' - '"{1}" is defined as an {2} repository') - fatal_error(msg.format(self.PROTOCOL_GIT, ext_name, - self[ext_name][self.REPO][self.PROTOCOL])) - - if (self[ext_name][self.REPO][self.PROTOCOL] != - self.PROTOCOL_EXTERNALS_ONLY): - ref_count = 0 - found_refs = '' - if self.TAG in self[ext_name][self.REPO]: - ref_count += 1 - found_refs = '"{0} = {1}", {2}'.format( - self.TAG, self[ext_name][self.REPO][self.TAG], - found_refs) - if self.BRANCH in self[ext_name][self.REPO]: - ref_count += 1 - found_refs = '"{0} = {1}", {2}'.format( - self.BRANCH, self[ext_name][self.REPO][self.BRANCH], - found_refs) - if self.HASH in self[ext_name][self.REPO]: - ref_count += 1 - found_refs = '"{0} = {1}", {2}'.format( - self.HASH, self[ext_name][self.REPO][self.HASH], - found_refs) - if (self.SUBMODULE in self[ext_name] and - self[ext_name][self.SUBMODULE]): - ref_count += 1 - found_refs = '"{0} = {1}", {2}'.format( - self.SUBMODULE, - self[ext_name][self.SUBMODULE], found_refs) - - if ref_count > 1: - msg = 'Model description is over specified! ' - if self.SUBMODULE in self[ext_name]: - msg += ('from_submodule is not compatible with ' - '"tag", "branch", or "hash" ') - else: - msg += (' Only one of "tag", "branch", or "hash" ' - 'may be specified ') - - msg += 'for repo description of "{0}".'.format(ext_name) - msg = '{0}\nFound: {1}'.format(msg, found_refs) - fatal_error(msg) - elif ref_count < 1: - msg = ('Model description is under specified! One of ' - '"tag", "branch", or "hash" must be specified for ' - 'repo description of "{0}"'.format(ext_name)) - fatal_error(msg) - - if (self.REPO_URL not in self[ext_name][self.REPO] and - (self.SUBMODULE not in self[ext_name] or - not self[ext_name][self.SUBMODULE])): - msg = ('Model description is under specified! Must have ' - '"repo_url" in repo ' - 'description for "{0}"'.format(ext_name)) - fatal_error(msg) - - if (self.SUBMODULE in self[ext_name] and - self[ext_name][self.SUBMODULE]): - if self.REPO_URL in self[ext_name][self.REPO]: - msg = ('Model description is over specified! ' - 'from_submodule keyword is not compatible ' - 'with {0} keyword for'.format(self.REPO_URL)) - msg = '{0} repo description of "{1}"'.format(msg, - ext_name) - fatal_error(msg) - - if self.PATH in self[ext_name]: - msg = ('Model description is over specified! ' - 'from_submodule keyword is not compatible with ' - '{0} keyword for'.format(self.PATH)) - msg = '{0} repo description of "{1}"'.format(msg, - ext_name) - fatal_error(msg) - - if self.REPO_URL in self[ext_name][self.REPO]: - url = expand_local_url( - self[ext_name][self.REPO][self.REPO_URL], ext_name) - self[ext_name][self.REPO][self.REPO_URL] = url - - def _check_optional(self): - # pylint: disable=too-many-branches - """Some fields like externals, repo:tag repo:branch are - (conditionally) optional. We don't want the user to be - required to enter them in every externals description file, but - still want to validate the input. Check conditions and add - default values if appropriate. - - """ - submod_desc = None # Only load submodules info once - for field in self: - # truely optional - if self.EXTERNALS not in self[field]: - self[field][self.EXTERNALS] = EMPTY_STR - - # git and svn repos must tags and branches for validation purposes. - if self.TAG not in self[field][self.REPO]: - self[field][self.REPO][self.TAG] = EMPTY_STR - if self.BRANCH not in self[field][self.REPO]: - self[field][self.REPO][self.BRANCH] = EMPTY_STR - if self.HASH not in self[field][self.REPO]: - self[field][self.REPO][self.HASH] = EMPTY_STR - if self.REPO_URL not in self[field][self.REPO]: - self[field][self.REPO][self.REPO_URL] = EMPTY_STR - - # from_submodule has a complex relationship with other fields - if self.SUBMODULE in self[field]: - # User wants to use submodule information, is it available? - if self._parent_repo is None: - # No parent == no submodule information - PPRINTER.pprint(self[field]) - msg = 'No parent submodule for "{0}"'.format(field) - fatal_error(msg) - elif self._parent_repo.protocol() != self.PROTOCOL_GIT: - PPRINTER.pprint(self[field]) - msg = 'Parent protocol, "{0}", does not support submodules' - fatal_error(msg.format(self._parent_repo.protocol())) - else: - args = self._repo_config_from_submodule(field, submod_desc) - repo_url, repo_path, ref_hash, submod_desc = args - - if repo_url is None: - msg = ('Cannot checkout "{0}" as a submodule, ' - 'repo not found in {1} file') - fatal_error(msg.format(field, - self.GIT_SUBMODULES_FILENAME)) - # Fill in submodule fields - self[field][self.REPO][self.REPO_URL] = repo_url - self[field][self.REPO][self.HASH] = ref_hash - self[field][self.PATH] = repo_path - - if self[field][self.SUBMODULE]: - # We should get everything from the parent submodule - # configuration. - pass - # No else (from _submodule = False is the default) - else: - # Add the default value (not using submodule information) - self[field][self.SUBMODULE] = False - - def _repo_config_from_submodule(self, field, submod_desc): - """Find the external config information for a repository from - its submodule configuration information. - """ - if submod_desc is None: - repo_path = os.getcwd() # Is this always correct? - submod_file = self._parent_repo.submodules_file(repo_path=repo_path) - if submod_file is None: - msg = ('Cannot checkout "{0}" from submodule information\n' - ' Parent repo, "{1}" does not have submodules') - fatal_error(msg.format(field, self._parent_repo.name())) - - submod_file = read_gitmodules_file(repo_path, submod_file) - submod_desc = create_externals_description(submod_file) - - # Can we find our external? - repo_url = None - repo_path = None - ref_hash = None - for ext_field in submod_desc: - if field == ext_field: - ext = submod_desc[ext_field] - repo_url = ext[self.REPO][self.REPO_URL] - repo_path = ext[self.PATH] - ref_hash = ext[self.REPO][self.HASH] - break - - return repo_url, repo_path, ref_hash, submod_desc - - def _validate(self): - """Validate that the parsed externals description contains all necessary - fields. - - """ - def print_compare_difference(data_a, data_b, loc_a, loc_b): - """Look through the data structures and print the differences. - - """ - for item in data_a: - if item in data_b: - if not isinstance(data_b[item], type(data_a[item])): - printlog(" {item}: {loc} = {val} ({val_type})".format( - item=item, loc=loc_a, val=data_a[item], - val_type=type(data_a[item]))) - printlog(" {item} {loc} = {val} ({val_type})".format( - item=' ' * len(item), loc=loc_b, val=data_b[item], - val_type=type(data_b[item]))) - else: - printlog(" {item}: {loc} = {val} ({val_type})".format( - item=item, loc=loc_a, val=data_a[item], - val_type=type(data_a[item]))) - printlog(" {item} {loc} missing".format( - item=' ' * len(item), loc=loc_b)) - - def validate_data_struct(schema, data): - """Compare a data structure against a schema and validate all required - fields are present. - - """ - is_valid = False - in_ref = True - valid = True - if isinstance(schema, dict) and isinstance(data, dict): - # Both are dicts, recursively verify that all fields - # in schema are present in the data. - for key in schema: - in_ref = in_ref and (key in data) - if in_ref: - valid = valid and ( - validate_data_struct(schema[key], data[key])) - - is_valid = in_ref and valid - else: - # non-recursive structure. verify data and schema have - # the same type. - is_valid = isinstance(data, type(schema)) - - if not is_valid: - printlog(" Unmatched schema and input:") - if isinstance(schema, dict): - print_compare_difference(schema, data, 'schema', 'input') - print_compare_difference(data, schema, 'input', 'schema') - else: - printlog(" schema = {0} ({1})".format( - schema, type(schema))) - printlog(" input = {0} ({1})".format(data, type(data))) - - return is_valid - - for field in self: - valid = validate_data_struct(self._source_schema, self[field]) - if not valid: - PPRINTER.pprint(self._source_schema) - PPRINTER.pprint(self[field]) - msg = 'ERROR: source for "{0}" did not validate'.format(field) - fatal_error(msg) - - -class ExternalsDescriptionDict(ExternalsDescription): - """Create a externals description object from a dictionary using the API - representations. Primarily used to simplify creating model - description files for unit testing. - - """ - - def __init__(self, model_data, components=None): - """Parse a native dictionary into a externals description. - """ - ExternalsDescription.__init__(self) - self._schema_major = 1 - self._schema_minor = 0 - self._schema_patch = 0 - self._input_major = 1 - self._input_minor = 0 - self._input_patch = 0 - self._verify_schema_version() - if components: - for key in model_data.items(): - if key not in components: - del model_data[key] - - self.update(model_data) - self._check_user_input() - - -class ExternalsDescriptionConfigV1(ExternalsDescription): - """Create a externals description object from a config_parser object, - schema version 1. - - """ - - def __init__(self, model_data, components=None, parent_repo=None): - """Convert the config data into a standardized dict that can be used to - construct the source objects - - """ - ExternalsDescription.__init__(self, parent_repo=parent_repo) - self._schema_major = 1 - self._schema_minor = 1 - self._schema_patch = 0 - self._input_major, self._input_minor, self._input_patch = \ - get_cfg_schema_version(model_data) - self._verify_schema_version() - self._remove_metadata(model_data) - self._parse_cfg(model_data, components=components) - self._check_user_input() - - @staticmethod - def _remove_metadata(model_data): - """Remove the metadata section from the model configuration file so - that it is simpler to look through the file and construct the - externals description. - - """ - model_data.remove_section(DESCRIPTION_SECTION) - - def _parse_cfg(self, cfg_data, components=None): - """Parse a config_parser object into a externals description. - """ - def list_to_dict(input_list, convert_to_lower_case=True): - """Convert a list of key-value pairs into a dictionary. - """ - output_dict = {} - for item in input_list: - key = config_string_cleaner(item[0].strip()) - value = config_string_cleaner(item[1].strip()) - if convert_to_lower_case: - key = key.lower() - output_dict[key] = value - return output_dict - - for section in cfg_data.sections(): - name = config_string_cleaner(section.lower().strip()) - if components and name not in components: - continue - self[name] = {} - self[name].update(list_to_dict(cfg_data.items(section))) - self[name][self.REPO] = {} - loop_keys = self[name].copy().keys() - for item in loop_keys: - if item in self._source_schema: - if isinstance(self._source_schema[item], bool): - self[name][item] = str_to_bool(self[name][item]) - elif item in self._source_schema[self.REPO]: - self[name][self.REPO][item] = self[name][item] - del self[name][item] - else: - msg = ('Invalid input: "{sect}" contains unknown ' - 'item "{item}".'.format(sect=name, item=item)) - fatal_error(msg) diff --git a/manage_externals/manic/externals_status.py b/manage_externals/manic/externals_status.py deleted file mode 100644 index d3d238f28..000000000 --- a/manage_externals/manic/externals_status.py +++ /dev/null @@ -1,164 +0,0 @@ -"""ExternalStatus - -Class to store status and state information about repositories and -create a string representation. - -""" -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -from .global_constants import EMPTY_STR -from .utils import printlog, indent_string -from .global_constants import VERBOSITY_VERBOSE, VERBOSITY_DUMP - - -class ExternalStatus(object): - """Class to represent the status of a given source repository or tree. - - Individual repositories determine their own status in the - Repository objects. This object is just resposible for storing the - information and passing it up to a higher level for reporting or - global decisions. - - There are two states of concern: - - * If the repository is in-sync with the externals description file. - - * If the repostiory working copy is clean and there are no pending - transactions (e.g. add, remove, rename, untracked files). - - """ - DEFAULT = '-' - UNKNOWN = '?' - EMPTY = 'e' - MODEL_MODIFIED = 's' # a.k.a. out-of-sync - DIRTY = 'M' - - STATUS_OK = ' ' - STATUS_ERROR = '!' - - # source types - OPTIONAL = 'o' - STANDALONE = 's' - MANAGED = ' ' - - def __init__(self): - self.sync_state = self.DEFAULT - self.clean_state = self.DEFAULT - self.source_type = self.DEFAULT - self.path = EMPTY_STR - self.current_version = EMPTY_STR - self.expected_version = EMPTY_STR - self.status_output = EMPTY_STR - - def log_status_message(self, verbosity): - """Write status message to the screen and log file - """ - self._default_status_message() - if verbosity >= VERBOSITY_VERBOSE: - self._verbose_status_message() - if verbosity >= VERBOSITY_DUMP: - self._dump_status_message() - - def _default_status_message(self): - """Return the default terse status message string - """ - msg = '{sync}{clean}{src_type} {path}'.format( - sync=self.sync_state, clean=self.clean_state, - src_type=self.source_type, path=self.path) - printlog(msg) - - def _verbose_status_message(self): - """Return the verbose status message string - """ - clean_str = self.DEFAULT - if self.clean_state == self.STATUS_OK: - clean_str = 'clean sandbox' - elif self.clean_state == self.DIRTY: - clean_str = 'modified sandbox' - - sync_str = 'on {0}'.format(self.current_version) - if self.sync_state != self.STATUS_OK: - sync_str = '{current} --> {expected}'.format( - current=self.current_version, expected=self.expected_version) - msg = ' {clean}, {sync}'.format(clean=clean_str, sync=sync_str) - printlog(msg) - - def _dump_status_message(self): - """Return the dump status message string - """ - msg = indent_string(self.status_output, 12) - printlog(msg) - - def safe_to_update(self): - """Report if it is safe to update a repository. Safe is defined as: - - * If a repository is empty, it is safe to update. - - * If a repository exists and has a clean working copy state - with no pending transactions. - - """ - safe_to_update = False - repo_exists = self.exists() - if not repo_exists: - safe_to_update = True - else: - # If the repo exists, it must be in ok or modified - # sync_state. Any other sync_state at this point - # represents a logic error that should have been handled - # before now! - sync_safe = ((self.sync_state == ExternalStatus.STATUS_OK) or - (self.sync_state == ExternalStatus.MODEL_MODIFIED)) - if sync_safe: - # The clean_state must be STATUS_OK to update. Otherwise we - # are dirty or there was a missed error previously. - if self.clean_state == ExternalStatus.STATUS_OK: - safe_to_update = True - return safe_to_update - - def exists(self): - """Determine if the repo exists. This is indicated by: - - * sync_state is not EMPTY - - * if the sync_state is empty, then the valid states for - clean_state are default, empty or unknown. Anything else - and there was probably an internal logic error. - - NOTE(bja, 2017-10) For the moment we are considering a - sync_state of default or unknown to require user intervention, - but we may want to relax this convention. This is probably a - result of a network error or internal logic error but more - testing is needed. - - """ - is_empty = (self.sync_state == ExternalStatus.EMPTY) - clean_valid = ((self.clean_state == ExternalStatus.DEFAULT) or - (self.clean_state == ExternalStatus.EMPTY) or - (self.clean_state == ExternalStatus.UNKNOWN)) - - if is_empty and clean_valid: - exists = False - else: - exists = True - return exists - - -def check_safe_to_update_repos(tree_status): - """Check if *ALL* repositories are in a safe state to update. We don't - want to do a partial update of the repositories then die, leaving - the model in an inconsistent state. - - Note: if there is an update to do, the repositories will by - definiation be out of synce with the externals description, so we - can't use that as criteria for updating. - - """ - safe_to_update = True - for comp in tree_status: - stat = tree_status[comp] - safe_to_update &= stat.safe_to_update() - - return safe_to_update diff --git a/manage_externals/manic/global_constants.py b/manage_externals/manic/global_constants.py deleted file mode 100644 index 0e91cffc9..000000000 --- a/manage_externals/manic/global_constants.py +++ /dev/null @@ -1,18 +0,0 @@ -"""Globals shared across modules -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import pprint - -EMPTY_STR = '' -LOCAL_PATH_INDICATOR = '.' -VERSION_SEPERATOR = '.' -LOG_FILE_NAME = 'manage_externals.log' -PPRINTER = pprint.PrettyPrinter(indent=4) - -VERBOSITY_DEFAULT = 0 -VERBOSITY_VERBOSE = 1 -VERBOSITY_DUMP = 2 diff --git a/manage_externals/manic/repository.py b/manage_externals/manic/repository.py deleted file mode 100644 index 4488c6be9..000000000 --- a/manage_externals/manic/repository.py +++ /dev/null @@ -1,97 +0,0 @@ -"""Base class representation of a repository -""" - -from .externals_description import ExternalsDescription -from .utils import fatal_error -from .global_constants import EMPTY_STR - - -class Repository(object): - """ - Class to represent and operate on a repository description. - """ - - def __init__(self, component_name, repo): - """ - Parse repo externals description - """ - self._name = component_name - self._protocol = repo[ExternalsDescription.PROTOCOL] - self._tag = repo[ExternalsDescription.TAG] - self._branch = repo[ExternalsDescription.BRANCH] - self._hash = repo[ExternalsDescription.HASH] - self._url = repo[ExternalsDescription.REPO_URL] - - if self._url is EMPTY_STR: - fatal_error('repo must have a URL') - - if ((self._tag is EMPTY_STR) and (self._branch is EMPTY_STR) and - (self._hash is EMPTY_STR)): - fatal_error('{0} repo must have a branch, tag or hash element') - - ref_count = 0 - if self._tag is not EMPTY_STR: - ref_count += 1 - if self._branch is not EMPTY_STR: - ref_count += 1 - if self._hash is not EMPTY_STR: - ref_count += 1 - if ref_count != 1: - fatal_error('repo {0} must have exactly one of ' - 'tag, branch or hash.'.format(self._name)) - - def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): # pylint: disable=unused-argument - """ - If the repo destination directory exists, ensure it is correct (from - correct URL, correct branch or tag), and possibly update the source. - If the repo destination directory does not exist, checkout the correce - branch or tag. - NB: is include as an argument for compatibility with - git functionality (repository_git.py) - """ - msg = ('DEV_ERROR: checkout method must be implemented in all ' - 'repository classes! {0}'.format(self.__class__.__name__)) - fatal_error(msg) - - def status(self, stat, repo_dir_path): # pylint: disable=unused-argument - """Report the status of the repo - - """ - msg = ('DEV_ERROR: status method must be implemented in all ' - 'repository classes! {0}'.format(self.__class__.__name__)) - fatal_error(msg) - - def submodules_file(self, repo_path=None): - # pylint: disable=no-self-use,unused-argument - """Stub for use by non-git VC systems""" - return None - - def url(self): - """Public access of repo url. - """ - return self._url - - def tag(self): - """Public access of repo tag - """ - return self._tag - - def branch(self): - """Public access of repo branch. - """ - return self._branch - - def hash(self): - """Public access of repo hash. - """ - return self._hash - - def name(self): - """Public access of repo name. - """ - return self._name - - def protocol(self): - """Public access of repo protocol. - """ - return self._protocol diff --git a/manage_externals/manic/repository_factory.py b/manage_externals/manic/repository_factory.py deleted file mode 100644 index 80a92a9d8..000000000 --- a/manage_externals/manic/repository_factory.py +++ /dev/null @@ -1,29 +0,0 @@ -"""Factory for creating and initializing the appropriate repository class -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -from .repository_git import GitRepository -from .repository_svn import SvnRepository -from .externals_description import ExternalsDescription -from .utils import fatal_error - - -def create_repository(component_name, repo_info, svn_ignore_ancestry=False): - """Determine what type of repository we have, i.e. git or svn, and - create the appropriate object. - - """ - protocol = repo_info[ExternalsDescription.PROTOCOL].lower() - if protocol == 'git': - repo = GitRepository(component_name, repo_info) - elif protocol == 'svn': - repo = SvnRepository(component_name, repo_info, ignore_ancestry=svn_ignore_ancestry) - elif protocol == 'externals_only': - repo = None - else: - msg = 'Unknown repo protocol "{0}"'.format(protocol) - fatal_error(msg) - return repo diff --git a/manage_externals/manic/repository_git.py b/manage_externals/manic/repository_git.py deleted file mode 100644 index c0e64eb55..000000000 --- a/manage_externals/manic/repository_git.py +++ /dev/null @@ -1,790 +0,0 @@ -"""Class for interacting with git repositories -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import copy -import os - -from .global_constants import EMPTY_STR, LOCAL_PATH_INDICATOR -from .global_constants import VERBOSITY_VERBOSE -from .repository import Repository -from .externals_status import ExternalStatus -from .externals_description import ExternalsDescription, git_submodule_status -from .utils import expand_local_url, split_remote_url, is_remote_url -from .utils import fatal_error, printlog -from .utils import execute_subprocess - - -class GitRepository(Repository): - """Class to represent and operate on a repository description. - - For testing purpose, all system calls to git should: - - * be isolated in separate functions with no application logic - * of the form: - - cmd = ['git', ...] - - value = execute_subprocess(cmd, output_to_caller={T|F}, - status_to_caller={T|F}) - - return value - * be static methods (not rely on self) - * name as _git_subcommand_args(user_args) - - This convention allows easy unit testing of the repository logic - by mocking the specific calls to return predefined results. - - """ - - def __init__(self, component_name, repo): - """ - Parse repo (a XML element). - """ - Repository.__init__(self, component_name, repo) - self._gitmodules = None - self._submods = None - - # ---------------------------------------------------------------- - # - # Public API, defined by Repository - # - # ---------------------------------------------------------------- - def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): - """ - If the repo destination directory exists, ensure it is correct (from - correct URL, correct branch or tag), and possibly update the source. - If the repo destination directory does not exist, checkout the correct - branch or tag. - """ - repo_dir_path = os.path.join(base_dir_path, repo_dir_name) - repo_dir_exists = os.path.exists(repo_dir_path) - if (repo_dir_exists and not os.listdir( - repo_dir_path)) or not repo_dir_exists: - self._clone_repo(base_dir_path, repo_dir_name, verbosity) - self._checkout_ref(repo_dir_path, verbosity, recursive) - gmpath = os.path.join(repo_dir_path, - ExternalsDescription.GIT_SUBMODULES_FILENAME) - if os.path.exists(gmpath): - self._gitmodules = gmpath - self._submods = git_submodule_status(repo_dir_path) - else: - self._gitmodules = None - self._submods = None - - def status(self, stat, repo_dir_path): - """ - If the repo destination directory exists, ensure it is correct (from - correct URL, correct branch or tag), and possibly update the source. - If the repo destination directory does not exist, checkout the correct - branch or tag. - """ - self._check_sync(stat, repo_dir_path) - if os.path.exists(repo_dir_path): - self._status_summary(stat, repo_dir_path) - - def submodules_file(self, repo_path=None): - if repo_path is not None: - gmpath = os.path.join(repo_path, - ExternalsDescription.GIT_SUBMODULES_FILENAME) - if os.path.exists(gmpath): - self._gitmodules = gmpath - self._submods = git_submodule_status(repo_path) - - return self._gitmodules - - # ---------------------------------------------------------------- - # - # Internal work functions - # - # ---------------------------------------------------------------- - def _clone_repo(self, base_dir_path, repo_dir_name, verbosity): - """Prepare to execute the clone by managing directory location - """ - cwd = os.getcwd() - os.chdir(base_dir_path) - self._git_clone(self._url, repo_dir_name, verbosity) - os.chdir(cwd) - - def _current_ref(self): - """Determine the *name* associated with HEAD. - - If we're on a branch, then returns the branch name; otherwise, - if we're on a tag, then returns the tag name; otherwise, returns - the current hash. Returns an empty string if no reference can be - determined (e.g., if we're not actually in a git repository). - """ - ref_found = False - - # If we're on a branch, then use that as the current ref - branch_found, branch_name = self._git_current_branch() - if branch_found: - current_ref = branch_name - ref_found = True - - if not ref_found: - # Otherwise, if we're exactly at a tag, use that as the - # current ref - tag_found, tag_name = self._git_current_tag() - if tag_found: - current_ref = tag_name - ref_found = True - - if not ref_found: - # Otherwise, use current hash as the current ref - hash_found, hash_name = self._git_current_hash() - if hash_found: - current_ref = hash_name - ref_found = True - - if not ref_found: - # If we still can't find a ref, return empty string. This - # can happen if we're not actually in a git repo - current_ref = '' - - return current_ref - - def _check_sync(self, stat, repo_dir_path): - """Determine whether a git repository is in-sync with the model - description. - - Because repos can have multiple remotes, the only criteria is - whether the branch or tag is the same. - - """ - if not os.path.exists(repo_dir_path): - # NOTE(bja, 2017-10) condition should have been determined - # by _Source() object and should never be here! - stat.sync_state = ExternalStatus.STATUS_ERROR - else: - git_dir = os.path.join(repo_dir_path, '.git') - if not os.path.exists(git_dir): - # NOTE(bja, 2017-10) directory exists, but no git repo - # info.... Can't test with subprocess git command - # because git will move up directory tree until it - # finds the parent repo git dir! - stat.sync_state = ExternalStatus.UNKNOWN - else: - self._check_sync_logic(stat, repo_dir_path) - - def _check_sync_logic(self, stat, repo_dir_path): - """Compare the underlying hashes of the currently checkout ref and the - expected ref. - - Output: sets the sync_state as well as the current and - expected ref in the input status object. - - """ - def compare_refs(current_ref, expected_ref): - """Compare the current and expected ref. - - """ - if current_ref == expected_ref: - status = ExternalStatus.STATUS_OK - else: - status = ExternalStatus.MODEL_MODIFIED - return status - - cwd = os.getcwd() - os.chdir(repo_dir_path) - - # get the full hash of the current commit - _, current_ref = self._git_current_hash() - - if self._branch: - if self._url == LOCAL_PATH_INDICATOR: - expected_ref = self._branch - else: - remote_name = self._determine_remote_name() - if not remote_name: - # git doesn't know about this remote. by definition - # this is a modified state. - expected_ref = "unknown_remote/{0}".format(self._branch) - else: - expected_ref = "{0}/{1}".format(remote_name, self._branch) - elif self._hash: - expected_ref = self._hash - elif self._tag: - expected_ref = self._tag - else: - msg = 'In repo "{0}": none of branch, hash or tag are set'.format( - self._name) - fatal_error(msg) - - # record the *names* of the current and expected branches - stat.current_version = self._current_ref() - stat.expected_version = copy.deepcopy(expected_ref) - - if current_ref == EMPTY_STR: - stat.sync_state = ExternalStatus.UNKNOWN - else: - # get the underlying hash of the expected ref - revparse_status, expected_ref_hash = self._git_revparse_commit( - expected_ref) - if revparse_status: - # We failed to get the hash associated with - # expected_ref. Maybe we should assign this to some special - # status, but for now we're just calling this out-of-sync to - # remain consistent with how this worked before. - stat.sync_state = ExternalStatus.MODEL_MODIFIED - else: - # compare the underlying hashes - stat.sync_state = compare_refs(current_ref, expected_ref_hash) - - os.chdir(cwd) - - def _determine_remote_name(self): - """Return the remote name. - - Note that this is for the *future* repo url and branch, not - the current working copy! - - """ - git_output = self._git_remote_verbose() - git_output = git_output.splitlines() - remote_name = '' - for line in git_output: - data = line.strip() - if not data: - continue - data = data.split() - name = data[0].strip() - url = data[1].strip() - if self._url == url: - remote_name = name - break - return remote_name - - def _create_remote_name(self): - """The url specified in the externals description file was not known - to git. We need to add it, which means adding a unique and - safe name.... - - The assigned name needs to be safe for git to use, e.g. can't - look like a path 'foo/bar' and work with both remote and local paths. - - Remote paths include but are not limited to: git, ssh, https, - github, gitlab, bitbucket, custom server, etc. - - Local paths can be relative or absolute. They may contain - shell variables, e.g. ${REPO_ROOT}/repo_name, or username - expansion, i.e. ~/ or ~someuser/. - - Relative paths must be at least one layer of redirection, i.e. - container/../ext_repo, but may be many layers deep, e.g. - container/../../../../../ext_repo - - NOTE(bja, 2017-11) - - The base name below may not be unique, for example if the - user has local paths like: - - /path/to/my/repos/nice_repo - /path/to/other/repos/nice_repo - - But the current implementation should cover most common - use cases for remotes and still provide usable names. - - """ - url = copy.deepcopy(self._url) - if is_remote_url(url): - url = split_remote_url(url) - else: - url = expand_local_url(url, self._name) - url = url.split('/') - repo_name = url[-1] - base_name = url[-2] - # repo name should nominally already be something that git can - # deal with. We need to remove other possibly troublesome - # punctuation, e.g. /, $, from the base name. - unsafe_characters = '!@#$%^&*()[]{}\\/,;~' - for unsafe in unsafe_characters: - base_name = base_name.replace(unsafe, '') - remote_name = "{0}_{1}".format(base_name, repo_name) - return remote_name - - def _checkout_ref(self, repo_dir, verbosity, submodules): - """Checkout the user supplied reference - if is True, recursively initialize and update - the repo's submodules - """ - # import pdb; pdb.set_trace() - cwd = os.getcwd() - os.chdir(repo_dir) - if self._url.strip() == LOCAL_PATH_INDICATOR: - self._checkout_local_ref(verbosity, submodules) - else: - self._checkout_external_ref(verbosity, submodules) - - os.chdir(cwd) - - def _checkout_local_ref(self, verbosity, submodules): - """Checkout the reference considering the local repo only. Do not - fetch any additional remotes or specify the remote when - checkout out the ref. - if is True, recursively initialize and update - the repo's submodules - """ - if self._tag: - ref = self._tag - elif self._branch: - ref = self._branch - else: - ref = self._hash - - self._check_for_valid_ref(ref) - self._git_checkout_ref(ref, verbosity, submodules) - - def _checkout_external_ref(self, verbosity, submodules): - """Checkout the reference from a remote repository - if is True, recursively initialize and update - the repo's submodules - """ - if self._tag: - ref = self._tag - elif self._branch: - ref = self._branch - else: - ref = self._hash - - remote_name = self._determine_remote_name() - if not remote_name: - remote_name = self._create_remote_name() - self._git_remote_add(remote_name, self._url) - self._git_fetch(remote_name) - - # NOTE(bja, 2018-03) we need to send separate ref and remote - # name to check_for_vaild_ref, but the combined name to - # checkout_ref! - self._check_for_valid_ref(ref, remote_name) - - if self._branch: - ref = '{0}/{1}'.format(remote_name, ref) - self._git_checkout_ref(ref, verbosity, submodules) - - def _check_for_valid_ref(self, ref, remote_name=None): - """Try some basic sanity checks on the user supplied reference so we - can provide a more useful error message than calledprocess - error... - - """ - is_tag = self._ref_is_tag(ref) - is_branch = self._ref_is_branch(ref, remote_name) - is_hash = self._ref_is_hash(ref) - - is_valid = is_tag or is_branch or is_hash - if not is_valid: - msg = ('In repo "{0}": reference "{1}" does not appear to be a ' - 'valid tag, branch or hash! Please verify the reference ' - 'name (e.g. spelling), is available from: {2} '.format( - self._name, ref, self._url)) - fatal_error(msg) - - if is_tag: - is_unique_tag, msg = self._is_unique_tag(ref, remote_name) - if not is_unique_tag: - msg = ('In repo "{0}": tag "{1}" {2}'.format( - self._name, self._tag, msg)) - fatal_error(msg) - - return is_valid - - def _is_unique_tag(self, ref, remote_name): - """Verify that a reference is a valid tag and is unique (not a branch) - - Tags may be tag names, or SHA id's. It is also possible that a - branch and tag have the some name. - - Note: values returned by git_showref_* and git_revparse are - shell return codes, which are zero for success, non-zero for - error! - - """ - is_tag = self._ref_is_tag(ref) - is_branch = self._ref_is_branch(ref, remote_name) - is_hash = self._ref_is_hash(ref) - - msg = '' - is_unique_tag = False - if is_tag and not is_branch: - # unique tag - msg = 'is ok' - is_unique_tag = True - elif is_tag and is_branch: - msg = ('is both a branch and a tag. git may checkout the branch ' - 'instead of the tag depending on your version of git.') - is_unique_tag = False - elif not is_tag and is_branch: - msg = ('is a branch, and not a tag. If you intended to checkout ' - 'a branch, please change the externals description to be ' - 'a branch. If you intended to checkout a tag, it does not ' - 'exist. Please check the name.') - is_unique_tag = False - else: # not is_tag and not is_branch: - if is_hash: - # probably a sha1 or HEAD, etc, we call it a tag - msg = 'is ok' - is_unique_tag = True - else: - # undetermined state. - msg = ('does not appear to be a valid tag, branch or hash! ' - 'Please check the name and repository.') - is_unique_tag = False - - return is_unique_tag, msg - - def _ref_is_tag(self, ref): - """Verify that a reference is a valid tag according to git. - - Note: values returned by git_showref_* and git_revparse are - shell return codes, which are zero for success, non-zero for - error! - """ - is_tag = False - value = self._git_showref_tag(ref) - if value == 0: - is_tag = True - return is_tag - - def _ref_is_branch(self, ref, remote_name=None): - """Verify if a ref is any kind of branch (local, tracked remote, - untracked remote). - - """ - local_branch = False - remote_branch = False - if remote_name: - remote_branch = self._ref_is_remote_branch(ref, remote_name) - local_branch = self._ref_is_local_branch(ref) - - is_branch = False - if local_branch or remote_branch: - is_branch = True - return is_branch - - def _ref_is_local_branch(self, ref): - """Verify that a reference is a valid branch according to git. - - show-ref branch returns local branches that have been - previously checked out. It will not necessarily pick up - untracked remote branches. - - Note: values returned by git_showref_* and git_revparse are - shell return codes, which are zero for success, non-zero for - error! - - """ - is_branch = False - value = self._git_showref_branch(ref) - if value == 0: - is_branch = True - return is_branch - - def _ref_is_remote_branch(self, ref, remote_name): - """Verify that a reference is a valid branch according to git. - - show-ref branch returns local branches that have been - previously checked out. It will not necessarily pick up - untracked remote branches. - - Note: values returned by git_showref_* and git_revparse are - shell return codes, which are zero for success, non-zero for - error! - - """ - is_branch = False - value = self._git_lsremote_branch(ref, remote_name) - if value == 0: - is_branch = True - return is_branch - - def _ref_is_commit(self, ref): - """Verify that a reference is a valid commit according to git. - - This could be a tag, branch, sha1 id, HEAD and potentially others... - - Note: values returned by git_showref_* and git_revparse are - shell return codes, which are zero for success, non-zero for - error! - """ - is_commit = False - value, _ = self._git_revparse_commit(ref) - if value == 0: - is_commit = True - return is_commit - - def _ref_is_hash(self, ref): - """Verify that a reference is a valid hash according to git. - - Git doesn't seem to provide an exact way to determine if user - supplied reference is an actual hash. So we verify that the - ref is a valid commit and return the underlying commit - hash. Then check that the commit hash begins with the user - supplied string. - - Note: values returned by git_showref_* and git_revparse are - shell return codes, which are zero for success, non-zero for - error! - - """ - is_hash = False - status, git_output = self._git_revparse_commit(ref) - if status == 0: - if git_output.strip().startswith(ref): - is_hash = True - return is_hash - - def _status_summary(self, stat, repo_dir_path): - """Determine the clean/dirty status of a git repository - - """ - cwd = os.getcwd() - os.chdir(repo_dir_path) - git_output = self._git_status_porcelain_v1z() - is_dirty = self._status_v1z_is_dirty(git_output) - if is_dirty: - stat.clean_state = ExternalStatus.DIRTY - else: - stat.clean_state = ExternalStatus.STATUS_OK - - # Now save the verbose status output incase the user wants to - # see it. - stat.status_output = self._git_status_verbose() - os.chdir(cwd) - - @staticmethod - def _status_v1z_is_dirty(git_output): - """Parse the git status output from --porcelain=v1 -z and determine if - the repo status is clean or dirty. Dirty means: - - * modified files - * missing files - * added files - * removed - * renamed - * unmerged - - Whether untracked files are considered depends on how the status - command was run (i.e., whether it was run with the '-u' option). - - NOTE: Based on the above definition, the porcelain status - should be an empty string to be considered 'clean'. Of course - this assumes we only get an empty string from an status - command on a clean checkout, and not some error - condition... Could alse use 'git diff --quiet'. - - """ - is_dirty = False - if git_output: - is_dirty = True - return is_dirty - - # ---------------------------------------------------------------- - # - # system call to git for information gathering - # - # ---------------------------------------------------------------- - @staticmethod - def _git_current_hash(): - """Return the full hash of the currently checked-out version. - - Returns a tuple, (hash_found, hash), where hash_found is a - logical specifying whether a hash was found for HEAD (False - could mean we're not in a git repository at all). (If hash_found - is False, then hash is ''.) - """ - status, git_output = GitRepository._git_revparse_commit("HEAD") - hash_found = not status - if not hash_found: - git_output = '' - return hash_found, git_output - - @staticmethod - def _git_current_branch(): - """Determines the name of the current branch. - - Returns a tuple, (branch_found, branch_name), where branch_found - is a logical specifying whether a branch name was found for - HEAD. (If branch_found is False, then branch_name is ''.) - """ - cmd = ['git', 'symbolic-ref', '--short', '-q', 'HEAD'] - status, git_output = execute_subprocess(cmd, - output_to_caller=True, - status_to_caller=True) - branch_found = not status - if branch_found: - git_output = git_output.strip() - else: - git_output = '' - return branch_found, git_output - - @staticmethod - def _git_current_tag(): - """Determines the name tag corresponding to HEAD (if any). - - Returns a tuple, (tag_found, tag_name), where tag_found is a - logical specifying whether we found a tag name corresponding to - HEAD. (If tag_found is False, then tag_name is ''.) - """ - # git describe --exact-match --tags HEAD - cmd = ['git', 'describe', '--exact-match', '--tags', 'HEAD'] - status, git_output = execute_subprocess(cmd, - output_to_caller=True, - status_to_caller=True) - tag_found = not status - if tag_found: - git_output = git_output.strip() - else: - git_output = '' - return tag_found, git_output - - @staticmethod - def _git_showref_tag(ref): - """Run git show-ref check if the user supplied ref is a tag. - - could also use git rev-parse --quiet --verify tagname^{tag} - """ - cmd = ['git', 'show-ref', '--quiet', '--verify', - 'refs/tags/{0}'.format(ref), ] - status = execute_subprocess(cmd, status_to_caller=True) - return status - - @staticmethod - def _git_showref_branch(ref): - """Run git show-ref check if the user supplied ref is a local or - tracked remote branch. - - """ - cmd = ['git', 'show-ref', '--quiet', '--verify', - 'refs/heads/{0}'.format(ref), ] - status = execute_subprocess(cmd, status_to_caller=True) - return status - - @staticmethod - def _git_lsremote_branch(ref, remote_name): - """Run git ls-remote to check if the user supplied ref is a remote - branch that is not being tracked - - """ - cmd = ['git', 'ls-remote', '--exit-code', '--heads', - remote_name, ref, ] - status = execute_subprocess(cmd, status_to_caller=True) - return status - - @staticmethod - def _git_revparse_commit(ref): - """Run git rev-parse to detect if a reference is a SHA, HEAD or other - valid commit. - - """ - cmd = ['git', 'rev-parse', '--quiet', '--verify', - '{0}^{1}'.format(ref, '{commit}'), ] - status, git_output = execute_subprocess(cmd, status_to_caller=True, - output_to_caller=True) - git_output = git_output.strip() - return status, git_output - - @staticmethod - def _git_status_porcelain_v1z(): - """Run git status to obtain repository information. - - This is run with '--untracked=no' to ignore untracked files. - - The machine-portable format that is guaranteed not to change - between git versions or *user configuration*. - - """ - cmd = ['git', 'status', '--untracked-files=no', '--porcelain', '-z'] - git_output = execute_subprocess(cmd, output_to_caller=True) - return git_output - - @staticmethod - def _git_status_verbose(): - """Run the git status command to obtain repository information. - """ - cmd = ['git', 'status'] - git_output = execute_subprocess(cmd, output_to_caller=True) - return git_output - - @staticmethod - def _git_remote_verbose(): - """Run the git remote command to obtain repository information. - """ - cmd = ['git', 'remote', '--verbose'] - git_output = execute_subprocess(cmd, output_to_caller=True) - return git_output - - @staticmethod - def has_submodules(repo_dir_path=None): - """Return True iff the repository at (or the current - directory if is None) has a '.gitmodules' file - """ - if repo_dir_path is None: - fname = ExternalsDescription.GIT_SUBMODULES_FILENAME - else: - fname = os.path.join(repo_dir_path, - ExternalsDescription.GIT_SUBMODULES_FILENAME) - - return os.path.exists(fname) - - # ---------------------------------------------------------------- - # - # system call to git for sideffects modifying the working tree - # - # ---------------------------------------------------------------- - @staticmethod - def _git_clone(url, repo_dir_name, verbosity): - """Run git clone for the side effect of creating a repository. - """ - cmd = ['git', 'clone', '--quiet'] - subcmd = None - - cmd.extend([url, repo_dir_name]) - if verbosity >= VERBOSITY_VERBOSE: - printlog(' {0}'.format(' '.join(cmd))) - execute_subprocess(cmd) - if subcmd is not None: - os.chdir(repo_dir_name) - execute_subprocess(subcmd) - - @staticmethod - def _git_remote_add(name, url): - """Run the git remote command for the side effect of adding a remote - """ - cmd = ['git', 'remote', 'add', name, url] - execute_subprocess(cmd) - - @staticmethod - def _git_fetch(remote_name): - """Run the git fetch command for the side effect of updating the repo - """ - cmd = ['git', 'fetch', '--quiet', '--tags', remote_name] - execute_subprocess(cmd) - - @staticmethod - def _git_checkout_ref(ref, verbosity, submodules): - """Run the git checkout command for the side effect of updating the repo - - Param: ref is a reference to a local or remote object in the - form 'origin/my_feature', or 'tag1'. - - """ - cmd = ['git', 'checkout', '--quiet', ref] - if verbosity >= VERBOSITY_VERBOSE: - printlog(' {0}'.format(' '.join(cmd))) - execute_subprocess(cmd) - if submodules: - GitRepository._git_update_submodules(verbosity) - - @staticmethod - def _git_update_submodules(verbosity): - """Run git submodule update for the side effect of updating this - repo's submodules. - """ - # First, verify that we have a .gitmodules file - if os.path.exists(ExternalsDescription.GIT_SUBMODULES_FILENAME): - cmd = ['git', 'submodule', 'update', '--init', '--recursive'] - if verbosity >= VERBOSITY_VERBOSE: - printlog(' {0}'.format(' '.join(cmd))) - - execute_subprocess(cmd) diff --git a/manage_externals/manic/repository_svn.py b/manage_externals/manic/repository_svn.py deleted file mode 100644 index 2f0d4d848..000000000 --- a/manage_externals/manic/repository_svn.py +++ /dev/null @@ -1,284 +0,0 @@ -"""Class for interacting with svn repositories -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import os -import re -import xml.etree.ElementTree as ET - -from .global_constants import EMPTY_STR, VERBOSITY_VERBOSE -from .repository import Repository -from .externals_status import ExternalStatus -from .utils import fatal_error, indent_string, printlog -from .utils import execute_subprocess - - -class SvnRepository(Repository): - """ - Class to represent and operate on a repository description. - - For testing purpose, all system calls to svn should: - - * be isolated in separate functions with no application logic - * of the form: - - cmd = ['svn', ...] - - value = execute_subprocess(cmd, output_to_caller={T|F}, - status_to_caller={T|F}) - - return value - * be static methods (not rely on self) - * name as _svn_subcommand_args(user_args) - - This convention allows easy unit testing of the repository logic - by mocking the specific calls to return predefined results. - - """ - RE_URLLINE = re.compile(r'^URL:') - - def __init__(self, component_name, repo, ignore_ancestry=False): - """ - Parse repo (a XML element). - """ - Repository.__init__(self, component_name, repo) - self._ignore_ancestry = ignore_ancestry - if self._branch: - self._url = os.path.join(self._url, self._branch) - elif self._tag: - self._url = os.path.join(self._url, self._tag) - else: - msg = "DEV_ERROR in svn repository. Shouldn't be here!" - fatal_error(msg) - - # ---------------------------------------------------------------- - # - # Public API, defined by Repository - # - # ---------------------------------------------------------------- - def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): # pylint: disable=unused-argument - """Checkout or update the working copy - - If the repo destination directory exists, switch the sandbox to - match the externals description. - - If the repo destination directory does not exist, checkout the - correct branch or tag. - NB: is include as an argument for compatibility with - git functionality (repository_git.py) - - """ - repo_dir_path = os.path.join(base_dir_path, repo_dir_name) - if os.path.exists(repo_dir_path): - cwd = os.getcwd() - os.chdir(repo_dir_path) - self._svn_switch(self._url, self._ignore_ancestry, verbosity) - # svn switch can lead to a conflict state, but it gives a - # return code of 0. So now we need to make sure that we're - # in a clean (non-conflict) state. - self._abort_if_dirty(repo_dir_path, - "Expected clean state following switch") - os.chdir(cwd) - else: - self._svn_checkout(self._url, repo_dir_path, verbosity) - - def status(self, stat, repo_dir_path): - """ - Check and report the status of the repository - """ - self._check_sync(stat, repo_dir_path) - if os.path.exists(repo_dir_path): - self._status_summary(stat, repo_dir_path) - - # ---------------------------------------------------------------- - # - # Internal work functions - # - # ---------------------------------------------------------------- - def _check_sync(self, stat, repo_dir_path): - """Check to see if repository directory exists and is at the expected - url. Return: status object - - """ - if not os.path.exists(repo_dir_path): - # NOTE(bja, 2017-10) this state should have been handled by - # the source object and we never get here! - stat.sync_state = ExternalStatus.STATUS_ERROR - else: - svn_output = self._svn_info(repo_dir_path) - if not svn_output: - # directory exists, but info returned nothing. .svn - # directory removed or incomplete checkout? - stat.sync_state = ExternalStatus.UNKNOWN - else: - stat.sync_state, stat.current_version = \ - self._check_url(svn_output, self._url) - stat.expected_version = '/'.join(self._url.split('/')[3:]) - - def _abort_if_dirty(self, repo_dir_path, message): - """Check if the repo is in a dirty state; if so, abort with a - helpful message. - - """ - - stat = ExternalStatus() - self._status_summary(stat, repo_dir_path) - if stat.clean_state != ExternalStatus.STATUS_OK: - status = self._svn_status_verbose(repo_dir_path) - status = indent_string(status, 4) - errmsg = """In directory - {cwd} - -svn status now shows: -{status} - -ERROR: {message} - -One possible cause of this problem is that there may have been untracked -files in your working directory that had the same name as tracked files -in the new revision. - -To recover: Clean up the above directory (resolving conflicts, etc.), -then rerun checkout_externals. -""".format(cwd=repo_dir_path, message=message, status=status) - - fatal_error(errmsg) - - @staticmethod - def _check_url(svn_output, expected_url): - """Determine the svn url from svn info output and return whether it - matches the expected value. - - """ - url = None - for line in svn_output.splitlines(): - if SvnRepository.RE_URLLINE.match(line): - url = line.split(': ')[1].strip() - break - if not url: - status = ExternalStatus.UNKNOWN - elif url == expected_url: - status = ExternalStatus.STATUS_OK - else: - status = ExternalStatus.MODEL_MODIFIED - - if url: - current_version = '/'.join(url.split('/')[3:]) - else: - current_version = EMPTY_STR - - return status, current_version - - def _status_summary(self, stat, repo_dir_path): - """Report whether the svn repository is in-sync with the model - description and whether the sandbox is clean or dirty. - - """ - svn_output = self._svn_status_xml(repo_dir_path) - is_dirty = self.xml_status_is_dirty(svn_output) - if is_dirty: - stat.clean_state = ExternalStatus.DIRTY - else: - stat.clean_state = ExternalStatus.STATUS_OK - - # Now save the verbose status output incase the user wants to - # see it. - stat.status_output = self._svn_status_verbose(repo_dir_path) - - @staticmethod - def xml_status_is_dirty(svn_output): - """Parse svn status xml output and determine if the working copy is - clean or dirty. Dirty is defined as: - - * modified files - * added files - * deleted files - * missing files - - Unversioned files do not affect the clean/dirty status. - - 'external' is also an acceptable state - - """ - # pylint: disable=invalid-name - SVN_EXTERNAL = 'external' - SVN_UNVERSIONED = 'unversioned' - # pylint: enable=invalid-name - - is_dirty = False - try: - xml_status = ET.fromstring(svn_output) - except BaseException: - fatal_error( - "SVN returned invalid XML message {}".format(svn_output)) - xml_target = xml_status.find('./target') - entries = xml_target.findall('./entry') - for entry in entries: - status = entry.find('./wc-status') - item = status.get('item') - if item == SVN_EXTERNAL: - continue - if item == SVN_UNVERSIONED: - continue - else: - is_dirty = True - break - return is_dirty - - # ---------------------------------------------------------------- - # - # system call to svn for information gathering - # - # ---------------------------------------------------------------- - @staticmethod - def _svn_info(repo_dir_path): - """Return results of svn info command - """ - cmd = ['svn', 'info', repo_dir_path] - output = execute_subprocess(cmd, output_to_caller=True) - return output - - @staticmethod - def _svn_status_verbose(repo_dir_path): - """capture the full svn status output - """ - cmd = ['svn', 'status', repo_dir_path] - svn_output = execute_subprocess(cmd, output_to_caller=True) - return svn_output - - @staticmethod - def _svn_status_xml(repo_dir_path): - """ - Get status of the subversion sandbox in repo_dir - """ - cmd = ['svn', 'status', '--xml', repo_dir_path] - svn_output = execute_subprocess(cmd, output_to_caller=True) - return svn_output - - # ---------------------------------------------------------------- - # - # system call to svn for sideffects modifying the working tree - # - # ---------------------------------------------------------------- - @staticmethod - def _svn_checkout(url, repo_dir_path, verbosity): - """ - Checkout a subversion repository (repo_url) to checkout_dir. - """ - cmd = ['svn', 'checkout', '--quiet', url, repo_dir_path] - if verbosity >= VERBOSITY_VERBOSE: - printlog(' {0}'.format(' '.join(cmd))) - execute_subprocess(cmd) - - @staticmethod - def _svn_switch(url, ignore_ancestry, verbosity): - """ - Switch branches for in an svn sandbox - """ - cmd = ['svn', 'switch', '--quiet'] - if ignore_ancestry: - cmd.append('--ignore-ancestry') - cmd.append(url) - if verbosity >= VERBOSITY_VERBOSE: - printlog(' {0}'.format(' '.join(cmd))) - execute_subprocess(cmd) diff --git a/manage_externals/manic/sourcetree.py b/manage_externals/manic/sourcetree.py deleted file mode 100644 index 83676b776..000000000 --- a/manage_externals/manic/sourcetree.py +++ /dev/null @@ -1,350 +0,0 @@ -""" - -FIXME(bja, 2017-11) External and SourceTree have a circular dependancy! -""" - -import errno -import logging -import os - -from .externals_description import ExternalsDescription -from .externals_description import read_externals_description_file -from .externals_description import create_externals_description -from .repository_factory import create_repository -from .repository_git import GitRepository -from .externals_status import ExternalStatus -from .utils import fatal_error, printlog -from .global_constants import EMPTY_STR, LOCAL_PATH_INDICATOR -from .global_constants import VERBOSITY_VERBOSE - -class _External(object): - """ - _External represents an external object inside a SourceTree - """ - - # pylint: disable=R0902 - - def __init__(self, root_dir, name, ext_description, svn_ignore_ancestry): - """Parse an external description file into a dictionary of externals. - - Input: - - root_dir : string - the root directory path where - 'local_path' is relative to. - - name : string - name of the ext_description object. may or may not - correspond to something in the path. - - ext_description : dict - source ExternalsDescription object - - svn_ignore_ancestry : bool - use --ignore-externals with svn switch - - """ - self._name = name - self._repo = None - self._externals = EMPTY_STR - self._externals_sourcetree = None - self._stat = ExternalStatus() - # Parse the sub-elements - - # _path : local path relative to the containing source tree - self._local_path = ext_description[ExternalsDescription.PATH] - # _repo_dir : full repository directory - repo_dir = os.path.join(root_dir, self._local_path) - self._repo_dir_path = os.path.abspath(repo_dir) - # _base_dir : base directory *containing* the repository - self._base_dir_path = os.path.dirname(self._repo_dir_path) - # repo_dir_name : base_dir_path + repo_dir_name = rep_dir_path - self._repo_dir_name = os.path.basename(self._repo_dir_path) - assert(os.path.join(self._base_dir_path, self._repo_dir_name) - == self._repo_dir_path) - - self._required = ext_description[ExternalsDescription.REQUIRED] - self._externals = ext_description[ExternalsDescription.EXTERNALS] - # Treat a .gitmodules file as a backup externals config - if not self._externals: - if GitRepository.has_submodules(self._repo_dir_path): - self._externals = ExternalsDescription.GIT_SUBMODULES_FILENAME - - repo = create_repository( - name, ext_description[ExternalsDescription.REPO], - svn_ignore_ancestry=svn_ignore_ancestry) - if repo: - self._repo = repo - - if self._externals and (self._externals.lower() != 'none'): - self._create_externals_sourcetree() - - def get_name(self): - """ - Return the external object's name - """ - return self._name - - def get_local_path(self): - """ - Return the external object's path - """ - return self._local_path - - def status(self): - """ - If the repo destination directory exists, ensure it is correct (from - correct URL, correct branch or tag), and possibly update the external. - If the repo destination directory does not exist, checkout the correce - branch or tag. - If load_all is True, also load all of the the externals sub-externals. - """ - - self._stat.path = self.get_local_path() - if not self._required: - self._stat.source_type = ExternalStatus.OPTIONAL - elif self._local_path == LOCAL_PATH_INDICATOR: - # LOCAL_PATH_INDICATOR, '.' paths, are standalone - # component directories that are not managed by - # checkout_externals. - self._stat.source_type = ExternalStatus.STANDALONE - else: - # managed by checkout_externals - self._stat.source_type = ExternalStatus.MANAGED - - ext_stats = {} - - if not os.path.exists(self._repo_dir_path): - self._stat.sync_state = ExternalStatus.EMPTY - msg = ('status check: repository directory for "{0}" does not ' - 'exist.'.format(self._name)) - logging.info(msg) - self._stat.current_version = 'not checked out' - # NOTE(bja, 2018-01) directory doesn't exist, so we cannot - # use repo to determine the expected version. We just take - # a best-guess based on the assumption that only tag or - # branch should be set, but not both. - if not self._repo: - self._stat.expected_version = 'unknown' - else: - self._stat.expected_version = self._repo.tag() + self._repo.branch() - else: - if self._repo: - self._repo.status(self._stat, self._repo_dir_path) - - if self._externals and self._externals_sourcetree: - # we expect externals and they exist - cwd = os.getcwd() - # SourceTree expects to be called from the correct - # root directory. - os.chdir(self._repo_dir_path) - ext_stats = self._externals_sourcetree.status(self._local_path) - os.chdir(cwd) - - all_stats = {} - # don't add the root component because we don't manage it - # and can't provide useful info about it. - if self._local_path != LOCAL_PATH_INDICATOR: - # store the stats under tha local_path, not comp name so - # it will be sorted correctly - all_stats[self._stat.path] = self._stat - - if ext_stats: - all_stats.update(ext_stats) - - return all_stats - - def checkout(self, verbosity, load_all): - """ - If the repo destination directory exists, ensure it is correct (from - correct URL, correct branch or tag), and possibly update the external. - If the repo destination directory does not exist, checkout the correct - branch or tag. - If load_all is True, also load all of the the externals sub-externals. - """ - if load_all: - pass - # Make sure we are in correct location - - if not os.path.exists(self._repo_dir_path): - # repository directory doesn't exist. Need to check it - # out, and for that we need the base_dir_path to exist - try: - os.makedirs(self._base_dir_path) - except OSError as error: - if error.errno != errno.EEXIST: - msg = 'Could not create directory "{0}"'.format( - self._base_dir_path) - fatal_error(msg) - - if self._stat.source_type != ExternalStatus.STANDALONE: - if verbosity >= VERBOSITY_VERBOSE: - # NOTE(bja, 2018-01) probably do not want to pass - # verbosity in this case, because if (verbosity == - # VERBOSITY_DUMP), then the previous status output would - # also be dumped, adding noise to the output. - self._stat.log_status_message(VERBOSITY_VERBOSE) - - if self._repo: - if self._stat.sync_state == ExternalStatus.STATUS_OK: - # If we're already in sync, avoid showing verbose output - # from the checkout command, unless the verbosity level - # is 2 or more. - checkout_verbosity = verbosity - 1 - else: - checkout_verbosity = verbosity - - self._repo.checkout(self._base_dir_path, self._repo_dir_name, - checkout_verbosity, self.clone_recursive()) - - def checkout_externals(self, verbosity, load_all): - """Checkout the sub-externals for this object - """ - if self.load_externals(): - if self._externals_sourcetree: - # NOTE(bja, 2018-02): the subtree externals objects - # were created during initial status check. Updating - # the external may have changed which sub-externals - # are needed. We need to delete those objects and - # re-read the potentially modified externals - # description file. - self._externals_sourcetree = None - self._create_externals_sourcetree() - self._externals_sourcetree.checkout(verbosity, load_all) - - def load_externals(self): - 'Return True iff an externals file should be loaded' - load_ex = False - if os.path.exists(self._repo_dir_path): - if self._externals: - if self._externals.lower() != 'none': - load_ex = os.path.exists(os.path.join(self._repo_dir_path, - self._externals)) - - return load_ex - - def clone_recursive(self): - 'Return True iff any .gitmodules files should be processed' - # Try recursive unless there is an externals entry - recursive = not self._externals - - return recursive - - def _create_externals_sourcetree(self): - """ - """ - if not os.path.exists(self._repo_dir_path): - # NOTE(bja, 2017-10) repository has not been checked out - # yet, can't process the externals file. Assume we are - # checking status before code is checkoud out and this - # will be handled correctly later. - return - - cwd = os.getcwd() - os.chdir(self._repo_dir_path) - if self._externals.lower() == 'none': - msg = ('Internal: Attempt to create source tree for ' - 'externals = none in {}'.format(self._repo_dir_path)) - fatal_error(msg) - - if not os.path.exists(self._externals): - if GitRepository.has_submodules(): - self._externals = ExternalsDescription.GIT_SUBMODULES_FILENAME - - if not os.path.exists(self._externals): - # NOTE(bja, 2017-10) this check is redundent with the one - # in read_externals_description_file! - msg = ('External externals description file "{0}" ' - 'does not exist! In directory: {1}'.format( - self._externals, self._repo_dir_path)) - fatal_error(msg) - - externals_root = self._repo_dir_path - model_data = read_externals_description_file(externals_root, - self._externals) - externals = create_externals_description(model_data, - parent_repo=self._repo) - self._externals_sourcetree = SourceTree(externals_root, externals) - os.chdir(cwd) - -class SourceTree(object): - """ - SourceTree represents a group of managed externals - """ - - def __init__(self, root_dir, model, svn_ignore_ancestry=False): - """ - Build a SourceTree object from a model description - """ - self._root_dir = os.path.abspath(root_dir) - self._all_components = {} - self._required_compnames = [] - for comp in model: - src = _External(self._root_dir, comp, model[comp], svn_ignore_ancestry) - self._all_components[comp] = src - if model[comp][ExternalsDescription.REQUIRED]: - self._required_compnames.append(comp) - - def status(self, relative_path_base=LOCAL_PATH_INDICATOR): - """Report the status components - - FIXME(bja, 2017-10) what do we do about situations where the - user checked out the optional components, but didn't add - optional for running status? What do we do where the user - didn't add optional to the checkout but did add it to the - status. -- For now, we run status on all components, and try - to do the right thing based on the results.... - - """ - load_comps = self._all_components.keys() - - summary = {} - for comp in load_comps: - printlog('{0}, '.format(comp), end='') - stat = self._all_components[comp].status() - for name in stat.keys(): - # check if we need to append the relative_path_base to - # the path so it will be sorted in the correct order. - if not stat[name].path.startswith(relative_path_base): - stat[name].path = os.path.join(relative_path_base, - stat[name].path) - # store under key = updated path, and delete the - # old key. - comp_stat = stat[name] - del stat[name] - stat[comp_stat.path] = comp_stat - summary.update(stat) - - return summary - - def checkout(self, verbosity, load_all, load_comp=None): - """ - Checkout or update indicated components into the the configured - subdirs. - - If load_all is True, recursively checkout all externals. - If load_all is False, load_comp is an optional set of components to load. - If load_all is True and load_comp is None, only load the required externals. - """ - if verbosity >= VERBOSITY_VERBOSE: - printlog('Checking out externals: ') - else: - printlog('Checking out externals: ', end='') - - if load_all: - load_comps = self._all_components.keys() - elif load_comp is not None: - load_comps = [load_comp] - else: - load_comps = self._required_compnames - - # checkout the primary externals - for comp in load_comps: - if verbosity < VERBOSITY_VERBOSE: - printlog('{0}, '.format(comp), end='') - else: - # verbose output handled by the _External object, just - # output a newline - printlog(EMPTY_STR) - self._all_components[comp].checkout(verbosity, load_all) - printlog('') - - # now give each external an opportunitity to checkout it's externals. - for comp in load_comps: - self._all_components[comp].checkout_externals(verbosity, load_all) diff --git a/manage_externals/manic/utils.py b/manage_externals/manic/utils.py deleted file mode 100644 index f57f43930..000000000 --- a/manage_externals/manic/utils.py +++ /dev/null @@ -1,330 +0,0 @@ -#!/usr/bin/env python -""" -Common public utilities for manic package - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import logging -import os -import subprocess -import sys -from threading import Timer - -from .global_constants import LOCAL_PATH_INDICATOR - -# --------------------------------------------------------------------- -# -# screen and logging output and functions to massage text for output -# -# --------------------------------------------------------------------- - - -def log_process_output(output): - """Log each line of process output at debug level so it can be - filtered if necessary. By default, output is a single string, and - logging.debug(output) will only put log info heading on the first - line. This makes it hard to filter with grep. - - """ - output = output.split('\n') - for line in output: - logging.debug(line) - - -def printlog(msg, **kwargs): - """Wrapper script around print to ensure that everything printed to - the screen also gets logged. - - """ - logging.info(msg) - if kwargs: - print(msg, **kwargs) - else: - print(msg) - sys.stdout.flush() - - -def last_n_lines(the_string, n_lines, truncation_message=None): - """Returns the last n lines of the given string - - Args: - the_string: str - n_lines: int - truncation_message: str, optional - - Returns a string containing the last n lines of the_string - - If truncation_message is provided, the returned string begins with - the given message if and only if the string is greater than n lines - to begin with. - """ - - lines = the_string.splitlines(True) - if len(lines) <= n_lines: - return_val = the_string - else: - lines_subset = lines[-n_lines:] - str_truncated = ''.join(lines_subset) - if truncation_message: - str_truncated = truncation_message + '\n' + str_truncated - return_val = str_truncated - - return return_val - - -def indent_string(the_string, indent_level): - """Indents the given string by a given number of spaces - - Args: - the_string: str - indent_level: int - - Returns a new string that is the same as the_string, except that - each line is indented by 'indent_level' spaces. - - In python3, this can be done with textwrap.indent. - """ - - lines = the_string.splitlines(True) - padding = ' ' * indent_level - lines_indented = [padding + line for line in lines] - return ''.join(lines_indented) - -# --------------------------------------------------------------------- -# -# error handling -# -# --------------------------------------------------------------------- - - -def fatal_error(message): - """ - Error output function - """ - logging.error(message) - raise RuntimeError("{0}ERROR: {1}".format(os.linesep, message)) - - -# --------------------------------------------------------------------- -# -# Data conversion / manipulation -# -# --------------------------------------------------------------------- -def str_to_bool(bool_str): - """Convert a sting representation of as boolean into a true boolean. - - Conversion should be case insensitive. - """ - value = None - str_lower = bool_str.lower() - if str_lower in ('true', 't'): - value = True - elif str_lower in ('false', 'f'): - value = False - if value is None: - msg = ('ERROR: invalid boolean string value "{0}". ' - 'Must be "true" or "false"'.format(bool_str)) - fatal_error(msg) - return value - - -REMOTE_PREFIXES = ['http://', 'https://', 'ssh://', 'git@'] - - -def is_remote_url(url): - """check if the user provided a local file path instead of a - remote. If so, it must be expanded to an absolute - path. - - """ - remote_url = False - for prefix in REMOTE_PREFIXES: - if url.startswith(prefix): - remote_url = True - return remote_url - - -def split_remote_url(url): - """check if the user provided a local file path or a - remote. If remote, try to strip off protocol info. - - """ - remote_url = is_remote_url(url) - if not remote_url: - return url - - for prefix in REMOTE_PREFIXES: - url = url.replace(prefix, '') - - if '@' in url: - url = url.split('@')[1] - - if ':' in url: - url = url.split(':')[1] - - return url - - -def expand_local_url(url, field): - """check if the user provided a local file path instead of a - remote. If so, it must be expanded to an absolute - path. - - Note: local paths of LOCAL_PATH_INDICATOR have special meaning and - represent local copy only, don't work with the remotes. - - """ - remote_url = is_remote_url(url) - if not remote_url: - if url.strip() == LOCAL_PATH_INDICATOR: - pass - else: - url = os.path.expandvars(url) - url = os.path.expanduser(url) - if not os.path.isabs(url): - msg = ('WARNING: Externals description for "{0}" contains a ' - 'url that is not remote and does not expand to an ' - 'absolute path. Version control operations may ' - 'fail.\n\nurl={1}'.format(field, url)) - printlog(msg) - else: - url = os.path.normpath(url) - return url - - -# --------------------------------------------------------------------- -# -# subprocess -# -# --------------------------------------------------------------------- - -# Give the user a helpful message if we detect that a command seems to -# be hanging. -_HANGING_SEC = 300 - - -def _hanging_msg(working_directory, command): - print(""" - -Command '{command}' -from directory {working_directory} -has taken {hanging_sec} seconds. It may be hanging. - -The command will continue to run, but you may want to abort -manage_externals with ^C and investigate. A possible cause of hangs is -when svn or git require authentication to access a private -repository. On some systems, svn and git requests for authentication -information will not be displayed to the user. In this case, the program -will appear to hang. Ensure you can run svn and git manually and access -all repositories without entering your authentication information. - -""".format(command=command, - working_directory=working_directory, - hanging_sec=_HANGING_SEC)) - - -def execute_subprocess(commands, status_to_caller=False, - output_to_caller=False): - """Wrapper around subprocess.check_output to handle common - exceptions. - - check_output runs a command with arguments and waits - for it to complete. - - check_output raises an exception on a nonzero return code. if - status_to_caller is true, execute_subprocess returns the subprocess - return code, otherwise execute_subprocess treats non-zero return - status as an error and raises an exception. - - """ - cwd = os.getcwd() - msg = 'In directory: {0}\nexecute_subprocess running command:'.format(cwd) - logging.info(msg) - commands_str = ' '.join(commands) - logging.info(commands_str) - return_to_caller = status_to_caller or output_to_caller - status = -1 - output = '' - hanging_timer = Timer(_HANGING_SEC, _hanging_msg, - kwargs={"working_directory": cwd, - "command": commands_str}) - hanging_timer.start() - try: - output = subprocess.check_output(commands, stderr=subprocess.STDOUT, - universal_newlines=True) - log_process_output(output) - status = 0 - except OSError as error: - msg = failed_command_msg( - 'Command execution failed. Does the executable exist?', - commands) - logging.error(error) - fatal_error(msg) - except ValueError as error: - msg = failed_command_msg( - 'DEV_ERROR: Invalid arguments trying to run subprocess', - commands) - logging.error(error) - fatal_error(msg) - except subprocess.CalledProcessError as error: - # Only report the error if we are NOT returning to the - # caller. If we are returning to the caller, then it may be a - # simple status check. If returning, it is the callers - # responsibility determine if an error occurred and handle it - # appropriately. - if not return_to_caller: - msg_context = ('Process did not run successfully; ' - 'returned status {0}'.format(error.returncode)) - msg = failed_command_msg(msg_context, commands, - output=error.output) - logging.error(error) - logging.error(msg) - log_process_output(error.output) - fatal_error(msg) - status = error.returncode - finally: - hanging_timer.cancel() - - if status_to_caller and output_to_caller: - ret_value = (status, output) - elif status_to_caller: - ret_value = status - elif output_to_caller: - ret_value = output - else: - ret_value = None - - return ret_value - - -def failed_command_msg(msg_context, command, output=None): - """Template for consistent error messages from subprocess calls. - - If 'output' is given, it should provide the output from the failed - command - """ - - if output: - output_truncated = last_n_lines(output, 20, - truncation_message='[... Output truncated for brevity ...]') - errmsg = ('Failed with output:\n' + - indent_string(output_truncated, 4) + - '\nERROR: ') - else: - errmsg = '' - - command_str = ' '.join(command) - errmsg += """In directory - {cwd} -{context}: - {command} -""".format(cwd=os.getcwd(), context=msg_context, command=command_str) - - if output: - errmsg += 'See above for output from failed command.\n' - - return errmsg diff --git a/manage_externals/test/.coveragerc b/manage_externals/test/.coveragerc deleted file mode 100644 index 8b681888b..000000000 --- a/manage_externals/test/.coveragerc +++ /dev/null @@ -1,7 +0,0 @@ -[run] -branch = True -omit = test_unit_*.py - test_sys_*.py - /usr/* - .local/* - */site-packages/* \ No newline at end of file diff --git a/manage_externals/test/.gitignore b/manage_externals/test/.gitignore deleted file mode 100644 index dd5795998..000000000 --- a/manage_externals/test/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -# virtual environments -env_python* - -# python code coverage tool output -.coverage -htmlcov - diff --git a/manage_externals/test/.pylint.rc b/manage_externals/test/.pylint.rc deleted file mode 100644 index 64abd03e4..000000000 --- a/manage_externals/test/.pylint.rc +++ /dev/null @@ -1,426 +0,0 @@ -[MASTER] - -# A comma-separated list of package or module names from where C extensions may -# be loaded. Extensions are loading into the active Python interpreter and may -# run arbitrary code -extension-pkg-whitelist= - -# Add files or directories to the blacklist. They should be base names, not -# paths. -ignore=.git,.svn,env2 - -# Add files or directories matching the regex patterns to the blacklist. The -# regex matches against base names, not paths. -ignore-patterns= - -# Python code to execute, usually for sys.path manipulation such as -# pygtk.require(). -#init-hook= - -# Use multiple processes to speed up Pylint. -jobs=1 - -# List of plugins (as comma separated values of python modules names) to load, -# usually to register additional checkers. -load-plugins= - -# Pickle collected data for later comparisons. -persistent=yes - -# Specify a configuration file. -#rcfile= - -# Allow loading of arbitrary C extensions. Extensions are imported into the -# active Python interpreter and may run arbitrary code. -unsafe-load-any-extension=no - - -[MESSAGES CONTROL] - -# Only show warnings with the listed confidence levels. Leave empty to show -# all. Valid levels: HIGH, INFERENCE, INFERENCE_FAILURE, UNDEFINED -confidence= - -# Disable the message, report, category or checker with the given id(s). You -# can either give multiple identifiers separated by comma (,) or put this -# option multiple times (only on the command line, not in the configuration -# file where it should appear only once).You can also use "--disable=all" to -# disable everything first and then reenable specific checks. For example, if -# you want to run only the similarities checker, you can use "--disable=all -# --enable=similarities". If you want to run only the classes checker, but have -# no Warning level messages displayed, use"--disable=all --enable=classes -# --disable=W" -disable=bad-continuation,useless-object-inheritance - - -# Enable the message, report, category or checker with the given id(s). You can -# either give multiple identifier separated by comma (,) or put this option -# multiple time (only on the command line, not in the configuration file where -# it should appear only once). See also the "--disable" option for examples. -enable= - - -[REPORTS] - -# Python expression which should return a note less than 10 (10 is the highest -# note). You have access to the variables errors warning, statement which -# respectively contain the number of errors / warnings messages and the total -# number of statements analyzed. This is used by the global evaluation report -# (RP0004). -evaluation=10.0 - ((float(5 * error + warning + refactor + convention) / statement) * 10) - -# Template used to display messages. This is a python new-style format string -# used to format the message information. See doc for all details -msg-template={msg_id}:{line:3d},{column:2d}: {msg} ({symbol}) - -# Set the output format. Available formats are text, parseable, colorized, json -# and msvs (visual studio).You can also give a reporter class, eg -# mypackage.mymodule.MyReporterClass. -output-format=text - -# Tells whether to display a full report or only the messages -#reports=yes - -# Activate the evaluation score. -score=yes - - -[REFACTORING] - -# Maximum number of nested blocks for function / method body -max-nested-blocks=5 - - -[BASIC] - -# Naming hint for argument names -argument-name-hint=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Regular expression matching correct argument names -argument-rgx=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Naming hint for attribute names -attr-name-hint=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Regular expression matching correct attribute names -attr-rgx=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Bad variable names which should always be refused, separated by a comma -bad-names=foo,bar,baz,toto,tutu,tata - -# Naming hint for class attribute names -class-attribute-name-hint=([A-Za-z_][A-Za-z0-9_]{2,30}|(__.*__))$ - -# Regular expression matching correct class attribute names -class-attribute-rgx=([A-Za-z_][A-Za-z0-9_]{2,30}|(__.*__))$ - -# Naming hint for class names -class-name-hint=[A-Z_][a-zA-Z0-9]+$ - -# Regular expression matching correct class names -class-rgx=[A-Z_][a-zA-Z0-9]+$ - -# Naming hint for constant names -const-name-hint=(([A-Z_][A-Z0-9_]*)|(__.*__))$ - -# Regular expression matching correct constant names -const-rgx=(([A-Z_][A-Z0-9_]*)|(__.*__))$ - -# Minimum line length for functions/classes that require docstrings, shorter -# ones are exempt. -docstring-min-length=-1 - -# Naming hint for function names -function-name-hint=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Regular expression matching correct function names -function-rgx=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Good variable names which should always be accepted, separated by a comma -good-names=i,j,k,ex,Run,_ - -# Include a hint for the correct naming format with invalid-name -include-naming-hint=no - -# Naming hint for inline iteration names -inlinevar-name-hint=[A-Za-z_][A-Za-z0-9_]*$ - -# Regular expression matching correct inline iteration names -inlinevar-rgx=[A-Za-z_][A-Za-z0-9_]*$ - -# Naming hint for method names -method-name-hint=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Regular expression matching correct method names -method-rgx=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Naming hint for module names -module-name-hint=(([a-z_][a-z0-9_]*)|([A-Z][a-zA-Z0-9]+))$ - -# Regular expression matching correct module names -module-rgx=(([a-z_][a-z0-9_]*)|([A-Z][a-zA-Z0-9]+))$ - -# Colon-delimited sets of names that determine each other's naming style when -# the name regexes allow several styles. -name-group= - -# Regular expression which should only match function or class names that do -# not require a docstring. -no-docstring-rgx=^_ - -# List of decorators that produce properties, such as abc.abstractproperty. Add -# to this list to register other decorators that produce valid properties. -property-classes=abc.abstractproperty - -# Naming hint for variable names -variable-name-hint=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - -# Regular expression matching correct variable names -variable-rgx=(([a-z][a-z0-9_]{2,30})|(_[a-z0-9_]*))$ - - -[FORMAT] - -# Expected format of line ending, e.g. empty (any line ending), LF or CRLF. -expected-line-ending-format= - -# Regexp for a line that is allowed to be longer than the limit. -ignore-long-lines=^\s*(# )??$ - -# Number of spaces of indent required inside a hanging or continued line. -indent-after-paren=4 - -# String used as indentation unit. This is usually " " (4 spaces) or "\t" (1 -# tab). -indent-string=' ' - -# Maximum number of characters on a single line. -max-line-length=100 - -# Maximum number of lines in a module -max-module-lines=1000 - -# List of optional constructs for which whitespace checking is disabled. `dict- -# separator` is used to allow tabulation in dicts, etc.: {1 : 1,\n222: 2}. -# `trailing-comma` allows a space between comma and closing bracket: (a, ). -# `empty-line` allows space-only lines. -no-space-check=trailing-comma,dict-separator - -# Allow the body of a class to be on the same line as the declaration if body -# contains single statement. -single-line-class-stmt=no - -# Allow the body of an if to be on the same line as the test if there is no -# else. -single-line-if-stmt=no - - -[LOGGING] - -# Logging modules to check that the string format arguments are in logging -# function parameter format -logging-modules=logging - - -[MISCELLANEOUS] - -# List of note tags to take in consideration, separated by a comma. -notes=FIXME,XXX,TODO - - -[SIMILARITIES] - -# Ignore comments when computing similarities. -ignore-comments=yes - -# Ignore docstrings when computing similarities. -ignore-docstrings=yes - -# Ignore imports when computing similarities. -ignore-imports=no - -# Minimum lines number of a similarity. -min-similarity-lines=4 - - -[SPELLING] - -# Spelling dictionary name. Available dictionaries: none. To make it working -# install python-enchant package. -spelling-dict= - -# List of comma separated words that should not be checked. -spelling-ignore-words= - -# A path to a file that contains private dictionary; one word per line. -spelling-private-dict-file= - -# Tells whether to store unknown words to indicated private dictionary in -# --spelling-private-dict-file option instead of raising a message. -spelling-store-unknown-words=no - - -[TYPECHECK] - -# List of decorators that produce context managers, such as -# contextlib.contextmanager. Add to this list to register other decorators that -# produce valid context managers. -contextmanager-decorators=contextlib.contextmanager - -# List of members which are set dynamically and missed by pylint inference -# system, and so shouldn't trigger E1101 when accessed. Python regular -# expressions are accepted. -generated-members= - -# Tells whether missing members accessed in mixin class should be ignored. A -# mixin class is detected if its name ends with "mixin" (case insensitive). -ignore-mixin-members=yes - -# This flag controls whether pylint should warn about no-member and similar -# checks whenever an opaque object is returned when inferring. The inference -# can return multiple potential results while evaluating a Python object, but -# some branches might not be evaluated, which results in partial inference. In -# that case, it might be useful to still emit no-member and other checks for -# the rest of the inferred objects. -ignore-on-opaque-inference=yes - -# List of class names for which member attributes should not be checked (useful -# for classes with dynamically set attributes). This supports the use of -# qualified names. -ignored-classes=optparse.Values,thread._local,_thread._local - -# List of module names for which member attributes should not be checked -# (useful for modules/projects where namespaces are manipulated during runtime -# and thus existing member attributes cannot be deduced by static analysis. It -# supports qualified module names, as well as Unix pattern matching. -ignored-modules= - -# Show a hint with possible names when a member name was not found. The aspect -# of finding the hint is based on edit distance. -missing-member-hint=yes - -# The minimum edit distance a name should have in order to be considered a -# similar match for a missing member name. -missing-member-hint-distance=1 - -# The total number of similar names that should be taken in consideration when -# showing a hint for a missing member. -missing-member-max-choices=1 - - -[VARIABLES] - -# List of additional names supposed to be defined in builtins. Remember that -# you should avoid to define new builtins when possible. -additional-builtins= - -# Tells whether unused global variables should be treated as a violation. -allow-global-unused-variables=yes - -# List of strings which can identify a callback function by name. A callback -# name must start or end with one of those strings. -callbacks=cb_,_cb - -# A regular expression matching the name of dummy variables (i.e. expectedly -# not used). -dummy-variables-rgx=_+$|(_[a-zA-Z0-9_]*[a-zA-Z0-9]+?$)|dummy|^ignored_|^unused_ - -# Argument names that match this expression will be ignored. Default to name -# with leading underscore -ignored-argument-names=_.*|^ignored_|^unused_ - -# Tells whether we should check for unused import in __init__ files. -init-import=no - -# List of qualified module names which can have objects that can redefine -# builtins. -redefining-builtins-modules=six.moves,future.builtins - - -[CLASSES] - -# List of method names used to declare (i.e. assign) instance attributes. -defining-attr-methods=__init__,__new__,setUp - -# List of member names, which should be excluded from the protected access -# warning. -exclude-protected=_asdict,_fields,_replace,_source,_make - -# List of valid names for the first argument in a class method. -valid-classmethod-first-arg=cls - -# List of valid names for the first argument in a metaclass class method. -valid-metaclass-classmethod-first-arg=mcs - - -[DESIGN] - -# Maximum number of arguments for function / method -max-args=5 - -# Maximum number of attributes for a class (see R0902). -max-attributes=7 - -# Maximum number of boolean expressions in a if statement -max-bool-expr=5 - -# Maximum number of branch for function / method body -max-branches=12 - -# Maximum number of locals for function / method body -max-locals=15 - -# Maximum number of parents for a class (see R0901). -max-parents=7 - -# Maximum number of public methods for a class (see R0904). -max-public-methods=20 - -# Maximum number of return / yield for function / method body -max-returns=6 - -# Maximum number of statements in function / method body -max-statements=50 - -# Minimum number of public methods for a class (see R0903). -min-public-methods=2 - - -[IMPORTS] - -# Allow wildcard imports from modules that define __all__. -allow-wildcard-with-all=no - -# Analyse import fallback blocks. This can be used to support both Python 2 and -# 3 compatible code, which means that the block might have code that exists -# only in one or another interpreter, leading to false positives when analysed. -analyse-fallback-blocks=no - -# Deprecated modules which should not be used, separated by a comma -deprecated-modules=regsub,TERMIOS,Bastion,rexec - -# Create a graph of external dependencies in the given file (report RP0402 must -# not be disabled) -ext-import-graph= - -# Create a graph of every (i.e. internal and external) dependencies in the -# given file (report RP0402 must not be disabled) -import-graph= - -# Create a graph of internal dependencies in the given file (report RP0402 must -# not be disabled) -int-import-graph= - -# Force import order to recognize a module as part of the standard -# compatibility libraries. -known-standard-library= - -# Force import order to recognize a module as part of a third party library. -known-third-party=enchant - - -[EXCEPTIONS] - -# Exceptions that will emit a warning when being caught. Defaults to -# "Exception" -overgeneral-exceptions=Exception diff --git a/manage_externals/test/Makefile b/manage_externals/test/Makefile deleted file mode 100644 index 293e36075..000000000 --- a/manage_externals/test/Makefile +++ /dev/null @@ -1,124 +0,0 @@ -python = not-set -verbose = not-set -debug = not-set - -ifneq ($(python), not-set) -PYTHON=$(python) -else -PYTHON=python -endif - -# we need the python path to point one level up to access the package -# and executables -PYPATH=PYTHONPATH=..: - -# common args for running tests -TEST_ARGS=-m unittest discover - -ifeq ($(debug), not-set) - ifeq ($(verbose), not-set) - # summary only output - TEST_ARGS+=--buffer - else - # show individual test summary - TEST_ARGS+=--buffer --verbose - endif -else - # show detailed test output - TEST_ARGS+=--verbose -endif - - -# auto reformat the code -AUTOPEP8=autopep8 -AUTOPEP8_ARGS=--aggressive --in-place - -# run lint -PYLINT=pylint -PYLINT_ARGS=-j 2 --rcfile=.pylint.rc - -# code coverage -COVERAGE=coverage -COVERAGE_ARGS=--rcfile=.coveragerc - -# source files -SRC = \ - ../checkout_externals \ - ../manic/*.py - -CHECKOUT_EXE = ../checkout_externals - -TEST_DIR = . - -README = ../README.md - -# -# testing -# -.PHONY : utest -utest : FORCE - $(PYPATH) $(PYTHON) $(TEST_ARGS) --pattern 'test_unit_*.py' - -.PHONY : stest -stest : FORCE - $(PYPATH) $(PYTHON) $(TEST_ARGS) --pattern 'test_sys_*.py' - -.PHONY : test -test : utest stest - -# -# documentation -# -.PHONY : readme -readme : $(CHECKOUT_EXE) - printf "%s\n\n" "-- AUTOMATICALLY GENERATED FILE. DO NOT EDIT --" > $(README) - printf "%s" '[![Build Status](https://travis-ci.org/ESMCI/manage_externals.svg?branch=master)](https://travis-ci.org/ESMCI/manage_externals)' >> $(README) - printf "%s" '[![Coverage Status](https://coveralls.io/repos/github/ESMCI/manage_externals/badge.svg?branch=master)](https://coveralls.io/github/ESMCI/manage_externals?branch=master)' >> $(README) - printf "\n%s\n" '```' >> $(README) - $(CHECKOUT_EXE) --help >> $(README) - -# -# coding standards -# -.PHONY : style -style : FORCE - $(AUTOPEP8) $(AUTOPEP8_ARGS) --recursive $(SRC) $(TEST_DIR)/test_*.py - -.PHONY : lint -lint : FORCE - $(PYLINT) $(PYLINT_ARGS) $(SRC) $(TEST_DIR)/test_*.py - -.PHONY : stylint -stylint : style lint - -.PHONY : coverage -# Need to use a single coverage run with a single pattern rather than -# using two separate commands with separate patterns for test_unit_*.py -# and test_sys_*.py: The latter clobbers some results from the first -# run, even if we use the --append flag to 'coverage run'. -coverage : FORCE - $(PYPATH) $(COVERAGE) erase - $(PYPATH) $(COVERAGE) run $(COVERAGE_ARGS) $(TEST_ARGS) --pattern 'test_*.py' - $(PYPATH) $(COVERAGE) html - -# -# virtual environment creation -# -.PHONY : env -env : FORCE - $(PYPATH) virtualenv --python $(PYTHON) $@_$(PYTHON) - . $@_$(PYTHON)/bin/activate; pip install -r requirements.txt - -# -# utilites -# -.PHONY : clean -clean : FORCE - -rm -rf *~ *.pyc tmp fake htmlcov - -.PHONY : clobber -clobber : clean - -rm -rf env_* - -FORCE : - diff --git a/manage_externals/test/README.md b/manage_externals/test/README.md deleted file mode 100644 index 938a900ee..000000000 --- a/manage_externals/test/README.md +++ /dev/null @@ -1,77 +0,0 @@ -# Testing for checkout_externals - -NOTE: Python2 is the supported runtime environment. Python3 compatibility is -in progress, complicated by the different proposed input methods -(yaml, xml, cfg/ini, json) and their different handling of strings -(unicode vs byte) in python2. Full python3 compatibility will be -possible once the number of possible input formats has been narrowed. - -## Setup development environment - -Development environments should be setup for python2 and python3: - -```SH - cd checkout_externals/test - make python=python2 env - make python=python3 env -``` - -## Unit tests - -Tests should be run for both python2 and python3. It is recommended -that you have seperate terminal windows open python2 and python3 -testing to avoid errors activating and deactivating environments. - -```SH - cd checkout_externals/test - . env_python2/bin/activate - make utest - deactivate -``` - -```SH - cd checkout_externals/test - . env_python2/bin/activate - make utest - deactivate -``` - -## System tests - -Not yet implemented. - -## Static analysis - -checkout_externals is difficult to test thoroughly because it relies -on git and svn, and svn requires a live network connection and -repository. Static analysis will help catch bugs in code paths that -are not being executed, but it requires conforming to community -standards and best practices. autopep8 and pylint should be run -regularly for automatic code formatting and linting. - -```SH - cd checkout_externals/test - . env_python2/bin/activate - make lint - deactivate -``` - -The canonical formatting for the code is whatever autopep8 -generates. All issues identified by pylint should be addressed. - - -## Code coverage - -All changes to the code should include maintaining existing tests and -writing new tests for new or changed functionality. To ensure test -coverage, run the code coverage tool: - -```SH - cd checkout_externals/test - . env_python2/bin/activate - make coverage - open -a Firefox.app htmlcov/index.html - deactivate -``` - - diff --git a/manage_externals/test/doc/.gitignore b/manage_externals/test/doc/.gitignore deleted file mode 100644 index d4e11e5ea..000000000 --- a/manage_externals/test/doc/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -_build - diff --git a/manage_externals/test/doc/Makefile b/manage_externals/test/doc/Makefile deleted file mode 100644 index 18f4d5bf9..000000000 --- a/manage_externals/test/doc/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -# Minimal makefile for Sphinx documentation -# - -# You can set these variables from the command line. -SPHINXOPTS = -SPHINXBUILD = sphinx-build -SPHINXPROJ = ManageExternals -SOURCEDIR = . -BUILDDIR = _build - -# Put it first so that "make" without argument is like "make help". -help: - @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) - -.PHONY: help Makefile - -# Catch-all target: route all unknown targets to Sphinx using the new -# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). -%: Makefile - @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) \ No newline at end of file diff --git a/manage_externals/test/doc/conf.py b/manage_externals/test/doc/conf.py deleted file mode 100644 index 469c0b0dc..000000000 --- a/manage_externals/test/doc/conf.py +++ /dev/null @@ -1,172 +0,0 @@ -# -*- coding: utf-8 -*- -# -# Manage Externals documentation build configuration file, created by -# sphinx-quickstart on Wed Nov 29 10:53:25 2017. -# -# This file is execfile()d with the current directory set to its -# containing dir. -# -# Note that not all possible configuration values are present in this -# autogenerated file. -# -# All configuration values have a default; values that are commented out -# serve to show the default. - -# If extensions (or modules to document with autodoc) are in another directory, -# add these directories to sys.path here. If the directory is relative to the -# documentation root, use os.path.abspath to make it absolute, like shown here. -# -# import os -# import sys -# sys.path.insert(0, os.path.abspath('.')) - - -# -- General configuration ------------------------------------------------ - -# If your documentation needs a minimal Sphinx version, state it here. -# -# needs_sphinx = '1.0' - -# Add any Sphinx extension module names here, as strings. They can be -# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom -# ones. -extensions = ['sphinx.ext.autodoc', - 'sphinx.ext.todo', - 'sphinx.ext.coverage', - 'sphinx.ext.viewcode', - 'sphinx.ext.githubpages'] - -# Add any paths that contain templates here, relative to this directory. -templates_path = ['_templates'] - -# The suffix(es) of source filenames. -# You can specify multiple suffix as a list of string: -# -# source_suffix = ['.rst', '.md'] -source_suffix = '.rst' - -# The master toctree document. -master_doc = 'index' - -# General information about the project. -project = u'Manage Externals' -copyright = u'2017, CSEG at NCAR' -author = u'CSEG at NCAR' - -# The version info for the project you're documenting, acts as replacement for -# |version| and |release|, also used in various other places throughout the -# built documents. -# -# The short X.Y version. -version = u'1.0.0' -# The full version, including alpha/beta/rc tags. -release = u'1.0.0' - -# The language for content autogenerated by Sphinx. Refer to documentation -# for a list of supported languages. -# -# This is also used if you do content translation via gettext catalogs. -# Usually you set "language" from the command line for these cases. -language = None - -# List of patterns, relative to source directory, that match files and -# directories to ignore when looking for source files. -# This patterns also effect to html_static_path and html_extra_path -exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] - -# The name of the Pygments (syntax highlighting) style to use. -pygments_style = 'sphinx' - -# If true, `todo` and `todoList` produce output, else they produce nothing. -todo_include_todos = True - - -# -- Options for HTML output ---------------------------------------------- - -# The theme to use for HTML and HTML Help pages. See the documentation for -# a list of builtin themes. -# -html_theme = 'alabaster' - -# Theme options are theme-specific and customize the look and feel of a theme -# further. For a list of options available for each theme, see the -# documentation. -# -# html_theme_options = {} - -# Add any paths that contain custom static files (such as style sheets) here, -# relative to this directory. They are copied after the builtin static files, -# so a file named "default.css" will overwrite the builtin "default.css". -html_static_path = ['_static'] - -# Custom sidebar templates, must be a dictionary that maps document names -# to template names. -# -# This is required for the alabaster theme -# refs: http://alabaster.readthedocs.io/en/latest/installation.html#sidebars -html_sidebars = { - '**': [ - 'relations.html', # needs 'show_related': True theme option to display - 'searchbox.html', - ] -} - - -# -- Options for HTMLHelp output ------------------------------------------ - -# Output file base name for HTML help builder. -htmlhelp_basename = 'ManageExternalsdoc' - - -# -- Options for LaTeX output --------------------------------------------- - -latex_elements = { - # The paper size ('letterpaper' or 'a4paper'). - # - # 'papersize': 'letterpaper', - - # The font size ('10pt', '11pt' or '12pt'). - # - # 'pointsize': '10pt', - - # Additional stuff for the LaTeX preamble. - # - # 'preamble': '', - - # Latex figure (float) alignment - # - # 'figure_align': 'htbp', -} - -# Grouping the document tree into LaTeX files. List of tuples -# (source start file, target name, title, -# author, documentclass [howto, manual, or own class]). -latex_documents = [ - (master_doc, 'ManageExternals.tex', u'Manage Externals Documentation', - u'CSEG at NCAR', 'manual'), -] - - -# -- Options for manual page output --------------------------------------- - -# One entry per manual page. List of tuples -# (source start file, name, description, authors, manual section). -man_pages = [ - (master_doc, 'manageexternals', u'Manage Externals Documentation', - [author], 1) -] - - -# -- Options for Texinfo output ------------------------------------------- - -# Grouping the document tree into Texinfo files. List of tuples -# (source start file, target name, title, author, -# dir menu entry, description, category) -texinfo_documents = [ - (master_doc, 'ManageExternals', u'Manage Externals Documentation', - author, 'ManageExternals', 'One line description of project.', - 'Miscellaneous'), -] - - - diff --git a/manage_externals/test/doc/develop.rst b/manage_externals/test/doc/develop.rst deleted file mode 100644 index b817b7b09..000000000 --- a/manage_externals/test/doc/develop.rst +++ /dev/null @@ -1,202 +0,0 @@ -Developer Guidelines -==================== - -The manage externals utilities are a light weight replacement for svn -externals that will work with git repositories pulling in a mixture of -git and svn dependencies. - -Given an externals description and a working copy: - -* *checkout_externals* attempts to make the working copy agree with the - externals description - -* *generate_externals* attempts to make the externals description agree - with the working copy. - -For these operations utilities should: - -* operate consistently across git and svn - -* operate simply with minimal user complexity - -* robustly across a wide range of repository states - -* provide explicit error messages when a problem occurs - -* leave the working copy in a valid state - -The utilities in manage externals are **NOT** generic wrappers around -revision control operations or a replacement for common tasks. Users -are expected to: - -* create branches prior to starting development - -* add remotes and push changes - -* create tags - -* delete branches - -These types of tasks are often highly workflow dependent, e.g. branch -naming conventions may vary between repositories, have the potential -to destroy user data, introduce significant code complexit and 'edge -cases' that are extremely difficult to detect and test, and often -require subtle decision making, especially if a problem occurs. - -Users who want to automate these types are encouraged to create their -own tools. The externals description files are explicitly versioned -and the internal APIs are intended to be stable for these purposes. - -Core Design Principles ------------------------ - -1. Users can, and are actively encouraged to, modify the externals - directories using revision control outside of manage_externals - tools. You can't make any assumptions about the state of the - working copy. Examples: adding a remote, creating a branch, - switching to a branch, deleting the directory entirely. - -2. Give that the user can do anything, the manage externals library - can not preserve state between calls. The only information it can - rely on is what it expectes based on the content of the externals - description file, and what the actual state of the directory tree - is. - -3. Do *not* do anything that will possibly destroy user data! - - a. Do not remove files from the file system. We are operating on - user supplied input. If you don't call 'rm', you can't - accidentally remove the user's data. Thinking of calling - ``shutil.rmtree(user_input)``? What if the user accidentally - specified user_input such that it resolves to their home - directory.... Yeah. Don't go there. - - b. Rely on git and svn to do their job as much as possible. Don't - duplicate functionality. Examples: - - i. We require the working copies to be 'clean' as reported by - ``git status`` and ``svn status``. What if there are misc - editor files floating around that prevent an update? Use the - git and svn ignore functionality so they are not - reported. Don't try to remove them from manage_externals or - determine if they are 'safe' to ignore. - - ii. Do not use '--force'. Ever. This is a sign you are doing - something dangerous, it may not be what the user - wants. Remember, they are encouraged to modify their repo. - -4. There are often multiple ways to obtain a particular piece of - information from git. Scraping screen output is brittle and - generally not considered a stable API across different versions of - git. Given a choice between: - - a. a lower level git 'plumbing' command that processes a - specific request and returns a sucess/failure status. - - b. high level git command that produces a bunch of output - that must be processed. - - We always prefer the former. It almost always involves - writing and maintaining less code and is more likely to be - stable. - -5. Backward compatibility is critical. We have *nested* - repositories. They are trivially easy to change versions. They may - have very different versions of the top level manage_externals. The - ability to read and work with old model description files is - critical to avoid problems for users. We also have automated tools - (testdb) that must generate and read external description - files. Backward compatibility will make staging changes vastly - simpler. - -Model Users ------------ - -Consider the needs of the following model userswhen developing manage_externals: - -* Users who will checkout the code once, and never change versions. - -* Users who will checkout the code once, then work for several years, - never updating. before trying to update or request integration. - -* Users develope code but do not use revision control beyond the - initial checkout. If they have modified or untracked files in the - repo, they may be irreplacable. Don't destroy user data. - -* Intermediate users who are working with multiple repos or branches - on a regular basis. They may only use manage_externals weekly or - monthly. Keep the user interface and documentation simple and - explicit. The more command line options they have to remember or - look up, the more frustrated they git. - -* Software engineers who use the tools multiple times a day. It should - get out of their way. - -User Interface --------------- - -Basic operation for the most standard use cases should be kept as -simple as possible. Many users will only rarely run the manage -utilities. Even advanced users don't like reading a lot of help -documentation or struggling to remember commands and piece together -what they need to run. Having many command line options, even if not -needed, is exteremly frustrating and overwhelming for most users. A few -simple, explicitly named commands are better than a single command -with many options. - -How will users get help if something goes wrong? This is a custom, -one-off solution. Searching the internet for manage_externals, will -only return the user doc for this project at best. There isn't likely -to be a stackoverflow question or blog post where someone else already -answered a user's question. And very few people outside this community -will be able to provide help if something goes wrong. The sooner we -kick users out of these utilities and into standard version control -tools, the better off they are going to be if they run into a problem. - -Repositories ------------- - -There are three basic types of repositories that must be considered: - -* container repositories - repositories that are always top level - repositories, and have a group of externals that must be managed. - -* simple repositories - repositories that are externals to another - repository, and do not have any of their own externals that will be - managed. - -* mixed use repositories - repositories that can act as a top level - container repository or as an external to a top level - container. They may also have their own sub-externals that are - required. They may have different externals needs depening on - whether they are top level or not. - -Repositories must be able to checkout and switch to both branches and -tags. - -Development -=========== - -The functionality to manage externals is broken into a library of core -functionality and applications built with the library. - -The core library is called 'manic', pseduo-homophone of (man)age -(ex)ternals that is: short, pronounceable and spell-checkable. It is -also no more or less meaningful to an unfamiliar user than a random -jumble of letters forming an acronym. - -The core architecture of manic is: - -* externals description - an abstract description on an external, - including of how to obtain it, where to obtain it, where it goes in - the working tree. - -* externals - the software object representing an external. - -* source trees - collection of externals - -* repository wrappers - object oriented wrappers around repository - operations. So the higher level management of the soure tree and - external does not have to be concerned with how a particular - external is obtained and managed. - diff --git a/manage_externals/test/doc/index.rst b/manage_externals/test/doc/index.rst deleted file mode 100644 index 9ab287ad8..000000000 --- a/manage_externals/test/doc/index.rst +++ /dev/null @@ -1,22 +0,0 @@ -.. Manage Externals documentation master file, created by - sphinx-quickstart on Wed Nov 29 10:53:25 2017. - You can adapt this file completely to your liking, but it should at least - contain the root `toctree` directive. - -Welcome to Manage Externals's documentation! -============================================ - -.. toctree:: - :maxdepth: 2 - :caption: Contents: - - - develop.rst - testing.rst - -Indices and tables -================== - -* :ref:`genindex` -* :ref:`modindex` -* :ref:`search` diff --git a/manage_externals/test/doc/testing.rst b/manage_externals/test/doc/testing.rst deleted file mode 100644 index 623f0e431..000000000 --- a/manage_externals/test/doc/testing.rst +++ /dev/null @@ -1,123 +0,0 @@ -Testing -======= - -The manage_externals package has an automated test suite. All pull -requests are expected to pass 100% of the automated tests, as well as -be pep8 and lint 'clean' and maintain approximately constant (at a -minimum) level of code coverage. - -Quick Start ------------ - -Do nothing approach -~~~~~~~~~~~~~~~~~~~ - -When you create a pull request on GitHub, Travis-CI continuous -integration testing will run the test suite in both python2 and -python3. Test results, lint results, and code coverage results are -available online. - -Do something approach -~~~~~~~~~~~~~~~~~~~~~ - -In the test directory, run: - -.. code-block:: shell - - make env - make lint - make test - make coverage - - -Automated Testing ------------------ - -The manage_externals manic library and executables are developed to be -python2 and python3 compatible using only the standard library. The -test suites meet the same requirements. But additional tools are -required to provide lint and code coverage metrics and generate -documentation. The requirements are maintained in the requirements.txt -file, and can be automatically installed into an isolated environment -via Makefile. - -Bootstrap requirements: - -* python2 - version 2.7.x or later - -* python3 - version 3.6 tested other versions may work - -* pip and virtualenv for python2 and python3 - -Note: all make rules can be of the form ``make python=pythonX rule`` -or ``make rule`` depending if you want to use the default system -python or specify a specific version. - -The Makefile in the test directory has the following rules: - -* ``make python=pythonX env`` - create a python virtual environment - for python2 or python3 and install all required packages. These - packages are required to run lint or coverage. - -* ``make style`` - runs autopep8 - -* ``make lint`` - runs autopep8 and pylint - -* ``make test`` - run the full test suite - -* ``make utest`` - run jus the unit tests - -* ``make stest`` - run jus the system integration tests - -* ``make coverage`` - run the full test suite through the code - coverage tool and generate an html report. - -* ``make readme`` - automatically generate the README files. - -* ``make clean`` - remove editor and pyc files - -* ``make clobber`` - remove all generated test files, including - virtual environments, coverage reports, and temporary test - repository directories. - -Unit Tests ----------- - -Unit tests are probably not 'true unit tests' for the pedantic, but -are pragmatic unit tests. They cover small practicle code blocks: -functions, class methods, and groups of functions and class methods. - -System Integration Tests ------------------------- - -NOTE(bja, 2017-11) The systems integration tests currently do not include svn repositories. - -The manage_externals package is extremely tedious and error prone to test manually. - -Combinations that must be tested to ensure basic functionality are: - -* container repository pulling in simple externals - -* container repository pulling in mixed externals with sub-externals. - -* mixed repository acting as a container, pulling in simple externals and sub-externals - -Automatic system tests are handled the same way manual testing is done: - -* clone a test repository - -* create an externals description file for the test - -* run the executable with the desired args - -* check the results - -* potentially modify the repo (checkout a different branch) - -* rerun and test - -* etc - -The automated system stores small test repositories in the main repo -by adding them as bare repositories. These repos are cloned via a -subprocess call to git and manipulated during the tests. diff --git a/manage_externals/test/repos/container.git/HEAD b/manage_externals/test/repos/container.git/HEAD deleted file mode 100644 index cb089cd89..000000000 --- a/manage_externals/test/repos/container.git/HEAD +++ /dev/null @@ -1 +0,0 @@ -ref: refs/heads/master diff --git a/manage_externals/test/repos/container.git/config b/manage_externals/test/repos/container.git/config deleted file mode 100644 index e6da23157..000000000 --- a/manage_externals/test/repos/container.git/config +++ /dev/null @@ -1,6 +0,0 @@ -[core] - repositoryformatversion = 0 - filemode = true - bare = true - ignorecase = true - precomposeunicode = true diff --git a/manage_externals/test/repos/container.git/description b/manage_externals/test/repos/container.git/description deleted file mode 100644 index 498b267a8..000000000 --- a/manage_externals/test/repos/container.git/description +++ /dev/null @@ -1 +0,0 @@ -Unnamed repository; edit this file 'description' to name the repository. diff --git a/manage_externals/test/repos/container.git/info/exclude b/manage_externals/test/repos/container.git/info/exclude deleted file mode 100644 index a5196d1be..000000000 --- a/manage_externals/test/repos/container.git/info/exclude +++ /dev/null @@ -1,6 +0,0 @@ -# git ls-files --others --exclude-from=.git/info/exclude -# Lines that start with '#' are comments. -# For a project mostly in C, the following would be a good set of -# exclude patterns (uncomment them if you want to use them): -# *.[oa] -# *~ diff --git a/manage_externals/test/repos/container.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 b/manage_externals/test/repos/container.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 deleted file mode 100644 index f65234e17f32800b1be0aa9908cc706458b14605..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 133 zcmV;00DAv;0acB$4#OY}L_6~pma=t7)Fr=DfpLNr2P1F?mVSF_r3_t8x_fuJAR6GY zuD1yyS3=Xu)WDKA@Ra});Xx7fWf1zv2~1TS@=422pQw4`eHcB9X3EwU=O)-GQ}s5s nqUZ%S7HaN3i|$`ck;m7Sz6S{Y_}`UoN%K{iOGozsJ+C?sZtFeC diff --git a/manage_externals/test/repos/container.git/objects/71/5b8f3e4afe1802a178e1d603af404ba45d59de b/manage_externals/test/repos/container.git/objects/71/5b8f3e4afe1802a178e1d603af404ba45d59de deleted file mode 100644 index 9759965b1ba440f1899216c1c82c0780fb65f46e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 136 zcmV;30C)d*0hNtQ3c@fDKwak)a{8g?ULFizQ5yOj!O$#BY{3QX>9e{j4e8<)

AV=y!@Ff%bx&`ZxO$xP47FG^)_lzn~QNUpn5)Pnq=ii~6DWK2pp8O#dS+Wke_L diff --git a/manage_externals/test/repos/container.git/objects/f9/e08370a737e941de6f6492e3f427c2ef4c1a03 b/manage_externals/test/repos/container.git/objects/f9/e08370a737e941de6f6492e3f427c2ef4c1a03 deleted file mode 100644 index 460fd7781917e095c826e8bc77ad53d943f199aa..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 81 zcmV-X0IvUd0R_Ry4S+BV1VG+Yu@&$_q5vvMU;#^(9XS?9_smrFie(;Fw=7}|1e56wgzpa&}fBkqfO*k&i_)dY`l?1hv=p}Fj<2Ge{uRcq{saZ z%j{g@HZ3wNvQv&lo|o_6gr*rieLQOSK`~u|R`NhFUI)68@B`BlpbA~$UTB9Ga*~zx a%Jelj*-|I)LF@ttC5adD0subgY(|R<&Qf{+ diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/01/97458f2dbe5fcd6bc44fa46983be0a30282379 b/manage_externals/test/repos/mixed-cont-ext.git/objects/01/97458f2dbe5fcd6bc44fa46983be0a30282379 deleted file mode 100644 index 032f4b1ca6bf0d25f1f9f419b1e7ab2aae1ef6c8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 171 zcmV;c095~Y0Zomu4uUWgMV;SQFt~~^I5;?f2d%r6C&MNz$f6Pi}^^zp3SC&knSt>TGbz78}9=ZOL8&?Fv(cG!`VtgKgN ZY{1E$27wP^7dQxMoWuzLd;nlTMfbC)Q$zp& diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/06/ea30b03ffa2f8574705f8b9583f7ca7e2dccf7 b/manage_externals/test/repos/mixed-cont-ext.git/objects/06/ea30b03ffa2f8574705f8b9583f7ca7e2dccf7 deleted file mode 100644 index 13d15a96a5071e98f0ba0cfbbdb2992c03990151..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 136 zcmV;30C)d*0hNtG4#FT106p`H{eaDGEd>%|)SJ(su+=pM4B|mwZ+(Kd$t05rB_(M< zmNu<2!_Lge2B#67kHO(Q1a!#· -MP…tæÇM¯0v&ù>î°KciåÇüÇ8V; \ No newline at end of file diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/1f/01fa46c17b1f38b37e6259f6e9d041bda3144f b/manage_externals/test/repos/mixed-cont-ext.git/objects/1f/01fa46c17b1f38b37e6259f6e9d041bda3144f deleted file mode 100644 index 7bacde68db5f1201015d4532aba9551660b05399..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 167 zcmV;Y09gNc0hNxy4Z<)C0C{H$F90%4+_Vxxz$T7kLnR0(O(n*sumP`oo$loMcuWmC z-)~w~gsCf*eiQX=*_sZfntbAHl&dTZ&5gE zmqjc(UfS(h;i3i3C0B(5e{oub>rV4>ggxy?ABf1q79*mQ-&@oFEO*Ws<|S?Qy{d)p VGuU)ju(jTFZd1AL+y`g^OR&}EOOOBn diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/37/f0e70b609adc90f4c09ee21d82ed1d79c81d69 b/manage_externals/test/repos/mixed-cont-ext.git/objects/37/f0e70b609adc90f4c09ee21d82ed1d79c81d69 deleted file mode 100644 index 8c6b04837ae4456cc5dc53ea7572610e6635d0d8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lzn`tC9-|*xG$A9N diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/38/9a2b876b8965d3c91a3db8d28a483eaf019d5c b/manage_externals/test/repos/mixed-cont-ext.git/objects/38/9a2b876b8965d3c91a3db8d28a483eaf019d5c deleted file mode 100644 index 1a35b74d479fdfb4bf24bcf199663fbb52036eee..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 130 zcmV-|0Db>>0V^p=O;s>7GGs6`FfcPQQP4}zEXhpI%P&f0aFl&|Gw+GS!K3kZ)1Ezh zejs~i1S3>cQEFmJZmM2MMG3=S(WPsHSWJ^Nk8w52YBee>u{sG;Ra}~+n_5wlT9lWV kQ>>Sqmd-GFVdTA?;?e&$HE}Vp-My(>AuMbJ03PHp2Cniq;{X5v diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 b/manage_externals/test/repos/mixed-cont-ext.git/objects/41/1de5d96ee418c1c55f3e96e6e6e7c06bb95801 deleted file mode 100644 index f65234e17f32800b1be0aa9908cc706458b14605..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 133 zcmV;00DAv;0acB$4#OY}L_6~pma=t7)Fr=DfpLNr2P1F?mVSF_r3_t8x_fuJAR6GY zuD1yyS3=Xu)WDKA@Ra});Xx7fWf1zv2~1TS@=422pQw4`eHcB9X3EwU=O)-GQ}s5s nqUZ%S7HaN3i|$`ck;m7Sz6S{Y_}`UoN%K{iOGozsJ+C?sZtFeC diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/6e/9f4baa6e94a0af4e094836c2eb55ccedef5fc4 b/manage_externals/test/repos/mixed-cont-ext.git/objects/6e/9f4baa6e94a0af4e094836c2eb55ccedef5fc4 deleted file mode 100644 index 6b2146cae4080fe2369401ecf5009fd9612c363c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 129 zcmV-{0Dk{?0V^p=O;s>7GGs6`FfcPQQP4}zEXhpI%P&f0aFl&|Gw+GS!K3kZ)1Ezh zejs~i1S3>cQEFmJZmM2MMG3=S(WPsHSWJ^Nk8w52YBee>u{sG;Ra}~+n_5wlT9lWV jQ>>Sqmd+qz)?FYbw&JLT!Zra%FYj6GAw1sz`R^`7StK`- diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/6f/c379457ecb4e576a13c7610ae1fa73f845ee6a b/manage_externals/test/repos/mixed-cont-ext.git/objects/6f/c379457ecb4e576a13c7610ae1fa73f845ee6a deleted file mode 100644 index 852a05113..000000000 --- a/manage_externals/test/repos/mixed-cont-ext.git/objects/6f/c379457ecb4e576a13c7610ae1fa73f845ee6a +++ /dev/null @@ -1 +0,0 @@ -x•ANÄ09çsãÄÊŽ;‘~2±ÛÊJÄ^MÆ,Ï'ì8õ¥«ÔÚ¾_•ÆyyR3ØlmvˆÆ•PB°Œ˜FCñ¼Î>»y¸± *Ùbla’«-n^]D§¥,Ùx»fvÖû2p×­ }¢ÒGÍzå¿xï‰å‚ÜßÈNvq~Z¢¡Òc›âÔ èÇyäç+QåT¤íÔt;]ŠC:ÝA¹Õg¥¿AÚ( XA÷G‰®µ*=i\†_øÀ^' \ No newline at end of file diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/93/a159deb9175bfeb2820a0006ddd92d78131332 b/manage_externals/test/repos/mixed-cont-ext.git/objects/93/a159deb9175bfeb2820a0006ddd92d78131332 deleted file mode 100644 index 682d799898667fc1b506c6daece665c1af824fc1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 169 zcmV;a09OBa0X2=i4uUWgg`MwHFu01a>EM8d!9g*|M#xPmH`1igdRvT%@!c&N$Mf@@ z(`wU3>1MmAof<6C(>I`v6dJAYeYA@l%k@73%f=gNbntJ=1Cup4@hq3GQ+7Tcu*$C$ z?z1w-GQSj97De^`@|sp*JpN(#NilT+t9T-4S&VZ28ie!20Ci{*k3u`_$Vpb#D>F9W XWKV;@2eAt}0BM}W2>^TmrSn6;Se#N% diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/95/80ecc12f16334ce44e42287d5d46f927bb7b75 b/manage_externals/test/repos/mixed-cont-ext.git/objects/95/80ecc12f16334ce44e42287d5d46f927bb7b75 deleted file mode 100644 index 33c9f6cdf..000000000 --- a/manage_externals/test/repos/mixed-cont-ext.git/objects/95/80ecc12f16334ce44e42287d5d46f927bb7b75 +++ /dev/null @@ -1 +0,0 @@ -x•ŽKNÄ0Yç½cÅÈŸLlK7é´Ÿ5#{ä´ŽO˜°z›ªÒ“¶mW%Ó“v€8¹³äÈÁ&¶eFö²òìÙ±$/¦äéÆUÉžÝz°RœÎJ¶¡”%ZY“ |YS“ìÄC/­Ó'*}ÔÜA¯ü7ïC¸ŸÇÛ‘²ÉÏ‹1‘^L0f’Ç7Åÿ¬©cì übå/ª¼Jo5½-Å®;íî Üê³Ò…¿AÚH:XA÷D×Z:ïÚ‡èè8M¿¸^æ \ No newline at end of file diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/a9/288dcd8a719a1f4ed3cba43a2a387ae7cd60fd b/manage_externals/test/repos/mixed-cont-ext.git/objects/a9/288dcd8a719a1f4ed3cba43a2a387ae7cd60fd deleted file mode 100644 index 73e7cbfbc8e106cee027f798dcb163ec6c5d21e6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 130 zcmV-|0Db>>0V^p=O;s>7GGs6`FfcPQQP4}zEXhpI%P&f0aFl&|Gw+GS!K3kZ)1Ezh zejs~i1S3>cQEFmJZmM2MMG3=S(WPsHSWJ^Nk8w52YBee>u{sG;Ra}~+n_5wlT9lWV kQ>>Sqmd?O9-L+qLU;NqZBmPS=oA+@UXed_#01>J$$h2KJZU6uP diff --git a/manage_externals/test/repos/mixed-cont-ext.git/objects/e8/ea32a11d30ee703f6f661ae7c2376f4ab84d38 b/manage_externals/test/repos/mixed-cont-ext.git/objects/e8/ea32a11d30ee703f6f661ae7c2376f4ab84d38 deleted file mode 100644 index 189ed85bb3c8b8642ae353d29a759f67040b5786..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 130 zcmV-|0Db>>0V^p=O;s>7GGs6`FfcPQQP4}zEXhpI%P&f0aFl&|Gw+GS!K3kZ)1Ezh zejs~i1S3>cQEFmJZmM2MMG3=S(WPsHSWJ^Nk8w52YBee>u{sG;Ra}~+n_5wlT9lWV kQ>>Sqmd?Q7Ty=.p¢ˆA -!ìÜ  w4ݵ¡¸Qªé€Øú=©Ã¤á¨ÏZ9ü0„þûkÌ éžG)* \ No newline at end of file diff --git a/manage_externals/test/repos/mixed-cont-ext.git/refs/heads/master b/manage_externals/test/repos/mixed-cont-ext.git/refs/heads/master deleted file mode 100644 index 1e0eef1ea..000000000 --- a/manage_externals/test/repos/mixed-cont-ext.git/refs/heads/master +++ /dev/null @@ -1 +0,0 @@ -6fc379457ecb4e576a13c7610ae1fa73f845ee6a diff --git a/manage_externals/test/repos/mixed-cont-ext.git/refs/heads/new-feature b/manage_externals/test/repos/mixed-cont-ext.git/refs/heads/new-feature deleted file mode 100644 index 607e80d1b..000000000 --- a/manage_externals/test/repos/mixed-cont-ext.git/refs/heads/new-feature +++ /dev/null @@ -1 +0,0 @@ -9580ecc12f16334ce44e42287d5d46f927bb7b75 diff --git a/manage_externals/test/repos/simple-ext-fork.git/HEAD b/manage_externals/test/repos/simple-ext-fork.git/HEAD deleted file mode 100644 index cb089cd89..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/HEAD +++ /dev/null @@ -1 +0,0 @@ -ref: refs/heads/master diff --git a/manage_externals/test/repos/simple-ext-fork.git/config b/manage_externals/test/repos/simple-ext-fork.git/config deleted file mode 100644 index 04eba1787..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/config +++ /dev/null @@ -1,8 +0,0 @@ -[core] - repositoryformatversion = 0 - filemode = true - bare = true - ignorecase = true - precomposeunicode = true -[remote "origin"] - url = /Users/andreb/projects/ncar/git-conversion/checkout-model-dev/cesm-demo-externals/manage_externals/test/repos/simple-ext.git diff --git a/manage_externals/test/repos/simple-ext-fork.git/description b/manage_externals/test/repos/simple-ext-fork.git/description deleted file mode 100644 index 498b267a8..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/description +++ /dev/null @@ -1 +0,0 @@ -Unnamed repository; edit this file 'description' to name the repository. diff --git a/manage_externals/test/repos/simple-ext-fork.git/info/exclude b/manage_externals/test/repos/simple-ext-fork.git/info/exclude deleted file mode 100644 index a5196d1be..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/info/exclude +++ /dev/null @@ -1,6 +0,0 @@ -# git ls-files --others --exclude-from=.git/info/exclude -# Lines that start with '#' are comments. -# For a project mostly in C, the following would be a good set of -# exclude patterns (uncomment them if you want to use them): -# *.[oa] -# *~ diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/00/fd13e76189f9134b0506b4b8ed3172723b467f b/manage_externals/test/repos/simple-ext-fork.git/objects/00/fd13e76189f9134b0506b4b8ed3172723b467f deleted file mode 100644 index ae28c037e5e8773bab7a7f9b6b050a01c3c8402a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lznAV=y!@Ff%bx&`ZxO$xP47FG^)_lzn&Ekz!U-;cU~)E`&5u^pl|A>?=DrCt|Zp*KGhtORPb%uc6q&p;{~x`YAHy z#2GbEv6YQH#`fOIuH1gSE*yL=Ojyh~{nIdqe*nnpf*T V&^Fln@|2-4tBgli^9u#mM`!{nPaFUM diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/11/a76e3d9a67313dec7ce1230852ab5c86352c5c b/manage_externals/test/repos/simple-ext-fork.git/objects/11/a76e3d9a67313dec7ce1230852ab5c86352c5c deleted file mode 100644 index 564e7bba6..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/objects/11/a76e3d9a67313dec7ce1230852ab5c86352c5c +++ /dev/null @@ -1,2 +0,0 @@ -x%ŒK -Â0@]çse&ßDÔ›L’!´˜¶„l¼½).¼Åãu.@Æ_ö¸Jê0ÇàìlM–Ä~v:ÄèmLÌÆi™åY*/ŸÛè@ŽpòÞ W ˆJ¥&Üå¿ø)´*Í \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/16/5506a7408a482f50493434e13fffeb44af893f b/manage_externals/test/repos/simple-ext-fork.git/objects/16/5506a7408a482f50493434e13fffeb44af893f deleted file mode 100644 index 0d738af68b021dcd9918c8f2047aa4fff55bf6e4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lznO)_H(Z zem6QZm^^8RnmiI`ubHzgrPye+FKRN0H9F;O5%17>8Q`NMJ?ehWT|!t)2i0Np3Z=u$N9svC-|`;J-!jY5fUp SfzGuJhQeX2oy8Y4sYkDN{z{Sn diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/32/7e97d86e941047d809dba58f2804740c6c30cf b/manage_externals/test/repos/simple-ext-fork.git/objects/32/7e97d86e941047d809dba58f2804740c6c30cf deleted file mode 100644 index 0999f0d4b9b4297e5677a96f3c9677bf408ee8d9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lzniemt(y-3DP$mtIvOOf diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/36/418b4e5665956a90725c9a1b5a8e551c5f3d48 b/manage_externals/test/repos/simple-ext-fork.git/objects/36/418b4e5665956a90725c9a1b5a8e551c5f3d48 deleted file mode 100644 index 9da8434f65ef3bfdb57cb8117e312a56663a31a2..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 159 zcmV;Q0AT-k0hNwh3c@fD0R7G>_5#Z8=Ft>H)JyoiX*NFFNQn2h9>Kq1U|^;?&-V_@ zcGH_GU?Q(kip?&NPmV1)rl3VdZ7GGKLl-2Pw=`WkjA`(0bci¹`ý}0…M”؇BÚÁs0/µâ¿}öï:: \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/3d/ec1fdf8e2f5edba28148c5db2fe8d7a842360b b/manage_externals/test/repos/simple-ext-fork.git/objects/3d/ec1fdf8e2f5edba28148c5db2fe8d7a842360b deleted file mode 100644 index 9a31c7ef2..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/objects/3d/ec1fdf8e2f5edba28148c5db2fe8d7a842360b +++ /dev/null @@ -1,2 +0,0 @@ -x•ŽKnÃ0 ³Ö)x”,ÊI½EÑŸ´–A¹Ü#t7o€ŒìÛ¶vp.žzS…ÁšÆƒ&oÑ„©d¦8¹xLd@™Ì‹›ÖCð6f¯% -œpt$‰m&ŽJd…¦¡øhøÝ—½Á—VxÔÒ®ùÉpŸ7^/²o7°d­K1ÂGDsØ#¯ë¿æ{o?Z 7®²€,\g½˜AV=y!@Ff%bx&`ZxO$xP47FG^)_lznAV=y!@Ff%bx&`ZxO$xP47FG^)_lznvGy0&Z${j?E8>6rD10GHRYE2d diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/5f/1d4786d12e52d7ab28d2f2f1118c1059a9f1ae b/manage_externals/test/repos/simple-ext-fork.git/objects/5f/1d4786d12e52d7ab28d2f2f1118c1059a9f1ae deleted file mode 100644 index 25488b7bfe52fd0d530e20393b752815d9aaf16f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 93 zcmV-j0HXhR0S(JB4ue1p1i;kyiv0l8%LNPZurX=iP=VtPL2T>`g? zkh3=;83|{%kTn0{lH8#Nev_`XVPmImRbRpwOIgehnBL{IWwXg diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/67/136e5ab4d5c1c65d10c8048763b96b0e53c1d6 b/manage_externals/test/repos/simple-ext-fork.git/objects/67/136e5ab4d5c1c65d10c8048763b96b0e53c1d6 deleted file mode 100644 index d3dfe31113715fe07ea6833f0c2a25e868ac20b2..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 165 zcmV;W09yZe0hNwR4#F@DL|Nw)z5pm6r*$QSfIWwB8k=t$6s6+&lq0Ykjo#?ZSf=UT zz+~D012)4Gj)~xM%ugTv-b1AFi TQ|c4S3@Y4~D&BknM3zUWvn5b3 diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/7b/0bd630ac13865735a1dff3437a137d8ab50663 b/manage_externals/test/repos/simple-ext-fork.git/objects/7b/0bd630ac13865735a1dff3437a137d8ab50663 deleted file mode 100644 index 0a2ec0494bc1600144cb54b61a6d7b43c7f3e806..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 119 zcmV--0Eqv10X50d4FVw$MNz-0;#IJTYiz*^YyjkKAhHY@MpwI+#E{&tb3>7U^YwDN zr`$2}=y`92Fm{8oNzW$w#gQ$c3ivT<^#zfQHTwFÁ©¹£rPkÖSèkJ´^ë \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/a4/2fe9144f5707bc1e9515ce1b44681f7aba6f95 b/manage_externals/test/repos/simple-ext-fork.git/objects/a4/2fe9144f5707bc1e9515ce1b44681f7aba6f95 deleted file mode 100644 index d8ba65454..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/objects/a4/2fe9144f5707bc1e9515ce1b44681f7aba6f95 +++ /dev/null @@ -1,3 +0,0 @@ -xUÌ[ -Â0…aŸ³ŠÙ@%Is+ˆ¨;™¤c/˜DÂq÷VðÅ×Ã>Æ ”w‡WJ Ú˜>8ò!¤!&'ƒS=)í±×CòF+ÑI2‚ßO‚Ts^Xðn`Ä2ÖBcw'ä­Ñw¨Á -\ËØNqÝ›F—)ãò8îç3(«¬Œ2:é¥ÿü0x-<×!6,i ª9 \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext-fork.git/objects/b9/3737be3ea6b19f6255983748a0a0f4d622f936 b/manage_externals/test/repos/simple-ext-fork.git/objects/b9/3737be3ea6b19f6255983748a0a0f4d622f936 deleted file mode 100644 index 9b40a0afa00b93a318cd503d3b29db1162978b03..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lznD—}ÂD>£Nƒv“{ŠZ¼M˜I…¥?jƒ‹Ìpžs8ÄgøÓ½„qÚ¥ZŽ€qo j†­f­ÕJ×{]þÕµÓ¥®¥Om/¨3Ü$ô¥‰Q_@ÞH© \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext-fork.git/packed-refs b/manage_externals/test/repos/simple-ext-fork.git/packed-refs deleted file mode 100644 index b8f9e8630..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/packed-refs +++ /dev/null @@ -1,5 +0,0 @@ -# pack-refs with: peeled fully-peeled sorted -36418b4e5665956a90725c9a1b5a8e551c5f3d48 refs/heads/feature2 -9b75494003deca69527bb64bcaa352e801611dd2 refs/heads/master -11a76e3d9a67313dec7ce1230852ab5c86352c5c refs/tags/tag1 -^9b75494003deca69527bb64bcaa352e801611dd2 diff --git a/manage_externals/test/repos/simple-ext-fork.git/refs/heads/feature2 b/manage_externals/test/repos/simple-ext-fork.git/refs/heads/feature2 deleted file mode 100644 index d223b0362..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/refs/heads/feature2 +++ /dev/null @@ -1 +0,0 @@ -f268d4e56d067da9bd1d85e55bdc40a8bd2b0bca diff --git a/manage_externals/test/repos/simple-ext-fork.git/refs/tags/abandoned-feature b/manage_externals/test/repos/simple-ext-fork.git/refs/tags/abandoned-feature deleted file mode 100644 index 8a18bf08e..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/refs/tags/abandoned-feature +++ /dev/null @@ -1 +0,0 @@ -a42fe9144f5707bc1e9515ce1b44681f7aba6f95 diff --git a/manage_externals/test/repos/simple-ext-fork.git/refs/tags/forked-feature-v1 b/manage_externals/test/repos/simple-ext-fork.git/refs/tags/forked-feature-v1 deleted file mode 100644 index 2764b552d..000000000 --- a/manage_externals/test/repos/simple-ext-fork.git/refs/tags/forked-feature-v1 +++ /dev/null @@ -1 +0,0 @@ -8d2b3b35126224c975d23f109aa1e3cbac452989 diff --git a/manage_externals/test/repos/simple-ext.git/HEAD b/manage_externals/test/repos/simple-ext.git/HEAD deleted file mode 100644 index cb089cd89..000000000 --- a/manage_externals/test/repos/simple-ext.git/HEAD +++ /dev/null @@ -1 +0,0 @@ -ref: refs/heads/master diff --git a/manage_externals/test/repos/simple-ext.git/config b/manage_externals/test/repos/simple-ext.git/config deleted file mode 100644 index e6da23157..000000000 --- a/manage_externals/test/repos/simple-ext.git/config +++ /dev/null @@ -1,6 +0,0 @@ -[core] - repositoryformatversion = 0 - filemode = true - bare = true - ignorecase = true - precomposeunicode = true diff --git a/manage_externals/test/repos/simple-ext.git/description b/manage_externals/test/repos/simple-ext.git/description deleted file mode 100644 index 498b267a8..000000000 --- a/manage_externals/test/repos/simple-ext.git/description +++ /dev/null @@ -1 +0,0 @@ -Unnamed repository; edit this file 'description' to name the repository. diff --git a/manage_externals/test/repos/simple-ext.git/info/exclude b/manage_externals/test/repos/simple-ext.git/info/exclude deleted file mode 100644 index a5196d1be..000000000 --- a/manage_externals/test/repos/simple-ext.git/info/exclude +++ /dev/null @@ -1,6 +0,0 @@ -# git ls-files --others --exclude-from=.git/info/exclude -# Lines that start with '#' are comments. -# For a project mostly in C, the following would be a good set of -# exclude patterns (uncomment them if you want to use them): -# *.[oa] -# *~ diff --git a/manage_externals/test/repos/simple-ext.git/objects/00/fd13e76189f9134b0506b4b8ed3172723b467f b/manage_externals/test/repos/simple-ext.git/objects/00/fd13e76189f9134b0506b4b8ed3172723b467f deleted file mode 100644 index ae28c037e5e8773bab7a7f9b6b050a01c3c8402a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lznbW_*ltIGSP}@rN;eRaRvTe4jec)&9#mV ztc{ztsDi^RDN|POQ7IsM3R)Zn^fb6Ap%fNDG*4c1YCyeUO2}@P$+4Hjj2b9dvLb3- zmJ-WQ2E*@mn-@6i1g9x43VXTpcO0*k$48gudH@`(^)|-1gKbZJZ&teIHT_#Om*271 ST(#ZC=?eOIX=gtC)=0=UK}@j# diff --git a/manage_externals/test/repos/simple-ext.git/objects/0b/15e8af3d4615b42314216efeae3fff184046a8 b/manage_externals/test/repos/simple-ext.git/objects/0b/15e8af3d4615b42314216efeae3fff184046a8 deleted file mode 100644 index 32d6896e3cb813edde3e4f0d0ca2d21963c2f1b0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lznåY*/ŸÛè@ŽpòÞ W ˆJ¥&Üå¿ø)´*Í \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext.git/objects/31/dbcd6de441e671a467ef317146539b7ffabb11 b/manage_externals/test/repos/simple-ext.git/objects/31/dbcd6de441e671a467ef317146539b7ffabb11 deleted file mode 100644 index 0f0db6797fe19372f1d2122ebe8aa5361df07c61..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 90 zcmV-g0HyzU0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lzn_5#Z8=Ft>H)JyoiX*NFFNQn2h9>Kq1U|^;?&-V_@ zcGH_GU?Q(kip?&NPmV1)rl3VdZ7GGKLl-2Pw=`WkjA`(0bciÁ©¹£rPkÖSèkJ´^ë \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext.git/objects/c5/b315915742133dbdfbeed0753e481b55c1d364 b/manage_externals/test/repos/simple-ext.git/objects/c5/b315915742133dbdfbeed0753e481b55c1d364 deleted file mode 100644 index 1d27accb5..000000000 --- a/manage_externals/test/repos/simple-ext.git/objects/c5/b315915742133dbdfbeed0753e481b55c1d364 +++ /dev/null @@ -1 +0,0 @@ -x ÈÁ € @ßT±øàeV` ›p ¹;£v¯É¼&מ±Äi+bø%˜œ£Ns(G7ñ®/nñ‚ÖÁÇ©-UlGj»ÐæV&¿”Yÿ+!|£òŠ \ No newline at end of file diff --git a/manage_externals/test/repos/simple-ext.git/objects/df/312890f93ba4d2c694208599b665c4a08afeff b/manage_externals/test/repos/simple-ext.git/objects/df/312890f93ba4d2c694208599b665c4a08afeff deleted file mode 100644 index 4018ea5914ee89b76d88fc282b6c98d80e4aaccd..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 89 zcmV-f0H*(V0V^p=O;s>AV=y!@Ff%bx&`ZxO$xP47FG^)_lzn=1.7.0 -autopep8>=1.3.0 -coverage>=4.4.0 -coveralls>=1.2.0 -sphinx>=1.6.0 diff --git a/manage_externals/test/test_sys_checkout.py b/manage_externals/test/test_sys_checkout.py deleted file mode 100644 index 63adcacdd..000000000 --- a/manage_externals/test/test_sys_checkout.py +++ /dev/null @@ -1,1827 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for checkout_externals - -Note: this script assume the path to the manic and -checkout_externals module is already in the python path. This is -usually handled by the makefile. If you call it directly, you may need -to adjust your path. - -NOTE(bja, 2017-11) If a test fails, we want to keep the repo for that -test. But the tests will keep running, so we need a unique name. Also, -tearDown is always called after each test. I haven't figured out how -to determine if an assertion failed and whether it is safe to clean up -the test repos. - -So the solution is: - -* assign a unique id to each test repo. - -* never cleanup during the run. - -* Erase any existing repos at the begining of the module in -setUpModule. - -""" - -# NOTE(bja, 2017-11) pylint complains that the module is too big, but -# I'm still working on how to break up the tests and still have the -# temporary directory be preserved.... -# pylint: disable=too-many-lines - - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import logging -import os -import os.path -import shutil -import unittest - -from manic.externals_description import ExternalsDescription -from manic.externals_description import DESCRIPTION_SECTION, VERSION_ITEM -from manic.externals_description import git_submodule_status -from manic.externals_status import ExternalStatus -from manic.repository_git import GitRepository -from manic.utils import printlog, execute_subprocess -from manic.global_constants import LOCAL_PATH_INDICATOR, VERBOSITY_DEFAULT -from manic.global_constants import LOG_FILE_NAME -from manic import checkout - -# ConfigParser was renamed in python2 to configparser. In python2, -# ConfigParser returns byte strings, str, instead of unicode. We need -# unicode to be compatible with xml and json parser and python3. -try: - # python2 - from ConfigParser import SafeConfigParser as config_parser -except ImportError: - # python3 - from configparser import ConfigParser as config_parser - -# --------------------------------------------------------------------- -# -# Global constants -# -# --------------------------------------------------------------------- - -# environment variable names -MANIC_TEST_BARE_REPO_ROOT = 'MANIC_TEST_BARE_REPO_ROOT' -MANIC_TEST_TMP_REPO_ROOT = 'MANIC_TEST_TMP_REPO_ROOT' - -# directory names -TMP_REPO_DIR_NAME = 'tmp' -BARE_REPO_ROOT_NAME = 'repos' -CONTAINER_REPO_NAME = 'container.git' -MIXED_REPO_NAME = 'mixed-cont-ext.git' -SIMPLE_REPO_NAME = 'simple-ext.git' -SIMPLE_FORK_NAME = 'simple-ext-fork.git' -SIMPLE_LOCAL_ONLY_NAME = '.' -ERROR_REPO_NAME = 'error' -EXTERNALS_NAME = 'externals' -SUB_EXTERNALS_PATH = 'src' -CFG_NAME = 'externals.cfg' -CFG_SUB_NAME = 'sub-externals.cfg' -README_NAME = 'readme.txt' -REMOTE_BRANCH_FEATURE2 = 'feature2' - -SVN_TEST_REPO = 'https://github.com/escomp/cesm' - - -def setUpModule(): # pylint: disable=C0103 - """Setup for all tests in this module. It is called once per module! - """ - logging.basicConfig(filename=LOG_FILE_NAME, - format='%(levelname)s : %(asctime)s : %(message)s', - datefmt='%Y-%m-%d %H:%M:%S', - level=logging.DEBUG) - repo_root = os.path.join(os.getcwd(), TMP_REPO_DIR_NAME) - repo_root = os.path.abspath(repo_root) - # delete if it exists from previous runs - try: - shutil.rmtree(repo_root) - except BaseException: - pass - # create clean dir for this run - os.mkdir(repo_root) - # set into the environment so var will be expanded in externals - # filess when executables are run - os.environ[MANIC_TEST_TMP_REPO_ROOT] = repo_root - - -class GenerateExternalsDescriptionCfgV1(object): - """Class to provide building blocks to create - ExternalsDescriptionCfgV1 files. - - Includes predefined files used in tests. - - """ - - def __init__(self): - self._schema_version = '1.1.0' - self._config = None - - def container_full(self, dest_dir): - """Create the full container config file with simple and mixed use - externals - - """ - self.create_config() - self.create_section(SIMPLE_REPO_NAME, 'simp_tag', - tag='tag1') - - self.create_section(SIMPLE_REPO_NAME, 'simp_branch', - branch=REMOTE_BRANCH_FEATURE2) - - self.create_section(SIMPLE_REPO_NAME, 'simp_opt', - tag='tag1', required=False) - - self.create_section(MIXED_REPO_NAME, 'mixed_req', - branch='master', externals=CFG_SUB_NAME) - - self.write_config(dest_dir) - - def container_simple_required(self, dest_dir): - """Create a container externals file with only simple externals. - - """ - self.create_config() - self.create_section(SIMPLE_REPO_NAME, 'simp_tag', - tag='tag1') - - self.create_section(SIMPLE_REPO_NAME, 'simp_branch', - branch=REMOTE_BRANCH_FEATURE2) - - self.create_section(SIMPLE_REPO_NAME, 'simp_hash', - ref_hash='60b1cc1a38d63') - - self.write_config(dest_dir) - - def container_simple_optional(self, dest_dir): - """Create a container externals file with optional simple externals - - """ - self.create_config() - self.create_section(SIMPLE_REPO_NAME, 'simp_req', - tag='tag1') - - self.create_section(SIMPLE_REPO_NAME, 'simp_opt', - tag='tag1', required=False) - - self.write_config(dest_dir) - - def container_simple_svn(self, dest_dir): - """Create a container externals file with only simple externals. - - """ - self.create_config() - self.create_section(SIMPLE_REPO_NAME, 'simp_tag', tag='tag1') - - self.create_svn_external('svn_branch', branch='trunk') - self.create_svn_external('svn_tag', tag='tags/cesm2.0.beta07') - - self.write_config(dest_dir) - - def mixed_simple_base(self, dest_dir): - """Create a mixed-use base externals file with only simple externals. - - """ - self.create_config() - self.create_section_ext_only('mixed_base') - self.create_section(SIMPLE_REPO_NAME, 'simp_tag', - tag='tag1') - - self.create_section(SIMPLE_REPO_NAME, 'simp_branch', - branch=REMOTE_BRANCH_FEATURE2) - - self.create_section(SIMPLE_REPO_NAME, 'simp_hash', - ref_hash='60b1cc1a38d63') - - self.write_config(dest_dir) - - def mixed_simple_sub(self, dest_dir): - """Create a mixed-use sub externals file with only simple externals. - - """ - self.create_config() - self.create_section(SIMPLE_REPO_NAME, 'simp_tag', - tag='tag1', path=SUB_EXTERNALS_PATH) - - self.create_section(SIMPLE_REPO_NAME, 'simp_branch', - branch=REMOTE_BRANCH_FEATURE2, - path=SUB_EXTERNALS_PATH) - - self.write_config(dest_dir, filename=CFG_SUB_NAME) - - def write_config(self, dest_dir, filename=CFG_NAME): - """Write the configuration file to disk - - """ - dest_path = os.path.join(dest_dir, filename) - with open(dest_path, 'w') as configfile: - self._config.write(configfile) - - def create_config(self): - """Create an config object and add the required metadata section - - """ - self._config = config_parser() - self.create_metadata() - - def create_metadata(self): - """Create the metadata section of the config file - """ - self._config.add_section(DESCRIPTION_SECTION) - - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, - self._schema_version) - - def create_section(self, repo_type, name, tag='', branch='', - ref_hash='', required=True, path=EXTERNALS_NAME, - externals='', repo_path=None, from_submodule=False): - # pylint: disable=too-many-branches - """Create a config section with autofilling some items and handling - optional items. - - """ - # pylint: disable=R0913 - self._config.add_section(name) - if not from_submodule: - self._config.set(name, ExternalsDescription.PATH, - os.path.join(path, name)) - - self._config.set(name, ExternalsDescription.PROTOCOL, - ExternalsDescription.PROTOCOL_GIT) - - # from_submodules is incompatible with some other options, turn them off - if (from_submodule and - ((repo_path is not None) or tag or ref_hash or branch)): - printlog('create_section: "from_submodule" is incompatible with ' - '"repo_url", "tag", "hash", and "branch" options;\n' - 'Ignoring those options for {}'.format(name)) - repo_url = None - tag = '' - ref_hash = '' - branch = '' - - if repo_path is not None: - repo_url = repo_path - else: - repo_url = os.path.join('${MANIC_TEST_BARE_REPO_ROOT}', repo_type) - - if not from_submodule: - self._config.set(name, ExternalsDescription.REPO_URL, repo_url) - - self._config.set(name, ExternalsDescription.REQUIRED, str(required)) - - if tag: - self._config.set(name, ExternalsDescription.TAG, tag) - - if branch: - self._config.set(name, ExternalsDescription.BRANCH, branch) - - if ref_hash: - self._config.set(name, ExternalsDescription.HASH, ref_hash) - - if externals: - self._config.set(name, ExternalsDescription.EXTERNALS, externals) - - if from_submodule: - self._config.set(name, ExternalsDescription.SUBMODULE, "True") - - def create_section_ext_only(self, name, - required=True, externals=CFG_SUB_NAME): - """Create a config section with autofilling some items and handling - optional items. - - """ - # pylint: disable=R0913 - self._config.add_section(name) - self._config.set(name, ExternalsDescription.PATH, LOCAL_PATH_INDICATOR) - - self._config.set(name, ExternalsDescription.PROTOCOL, - ExternalsDescription.PROTOCOL_EXTERNALS_ONLY) - - self._config.set(name, ExternalsDescription.REPO_URL, - LOCAL_PATH_INDICATOR) - - self._config.set(name, ExternalsDescription.REQUIRED, str(required)) - - if externals: - self._config.set(name, ExternalsDescription.EXTERNALS, externals) - - def create_svn_external(self, name, tag='', branch=''): - """Create a config section for an svn repository. - - """ - self._config.add_section(name) - self._config.set(name, ExternalsDescription.PATH, - os.path.join(EXTERNALS_NAME, name)) - - self._config.set(name, ExternalsDescription.PROTOCOL, - ExternalsDescription.PROTOCOL_SVN) - - self._config.set(name, ExternalsDescription.REPO_URL, SVN_TEST_REPO) - - self._config.set(name, ExternalsDescription.REQUIRED, str(True)) - - if tag: - self._config.set(name, ExternalsDescription.TAG, tag) - - if branch: - self._config.set(name, ExternalsDescription.BRANCH, branch) - - @staticmethod - def create_branch(dest_dir, repo_name, branch, with_commit=False): - """Update a repository branch, and potentially the remote. - """ - # pylint: disable=R0913 - cwd = os.getcwd() - repo_root = os.path.join(dest_dir, EXTERNALS_NAME) - repo_root = os.path.join(repo_root, repo_name) - os.chdir(repo_root) - cmd = ['git', 'checkout', '-b', branch, ] - execute_subprocess(cmd) - if with_commit: - msg = 'start work on {0}'.format(branch) - with open(README_NAME, 'a') as handle: - handle.write(msg) - cmd = ['git', 'add', README_NAME, ] - execute_subprocess(cmd) - cmd = ['git', 'commit', '-m', msg, ] - execute_subprocess(cmd) - os.chdir(cwd) - - @staticmethod - def create_commit(dest_dir, repo_name, local_tracking_branch=None): - """Make a commit on whatever is currently checked out. - - This is used to test sync state changes from local commits on - detached heads and tracking branches. - - """ - cwd = os.getcwd() - repo_root = os.path.join(dest_dir, EXTERNALS_NAME) - repo_root = os.path.join(repo_root, repo_name) - os.chdir(repo_root) - if local_tracking_branch: - cmd = ['git', 'checkout', '-b', local_tracking_branch, ] - execute_subprocess(cmd) - - msg = 'work on great new feature!' - with open(README_NAME, 'a') as handle: - handle.write(msg) - cmd = ['git', 'add', README_NAME, ] - execute_subprocess(cmd) - cmd = ['git', 'commit', '-m', msg, ] - execute_subprocess(cmd) - os.chdir(cwd) - - def update_branch(self, dest_dir, name, branch, repo_type=None, - filename=CFG_NAME): - """Update a repository branch, and potentially the remote. - """ - # pylint: disable=R0913 - self._config.set(name, ExternalsDescription.BRANCH, branch) - - if repo_type: - if repo_type == SIMPLE_LOCAL_ONLY_NAME: - repo_url = SIMPLE_LOCAL_ONLY_NAME - else: - repo_url = os.path.join('${MANIC_TEST_BARE_REPO_ROOT}', - repo_type) - self._config.set(name, ExternalsDescription.REPO_URL, repo_url) - - try: - # remove the tag if it existed - self._config.remove_option(name, ExternalsDescription.TAG) - except BaseException: - pass - - self.write_config(dest_dir, filename) - - def update_svn_branch(self, dest_dir, name, branch, filename=CFG_NAME): - """Update a repository branch, and potentially the remote. - """ - # pylint: disable=R0913 - self._config.set(name, ExternalsDescription.BRANCH, branch) - - try: - # remove the tag if it existed - self._config.remove_option(name, ExternalsDescription.TAG) - except BaseException: - pass - - self.write_config(dest_dir, filename) - - def update_tag(self, dest_dir, name, tag, repo_type=None, - filename=CFG_NAME, remove_branch=True): - """Update a repository tag, and potentially the remote - - NOTE(bja, 2017-11) remove_branch=False should result in an - overspecified external with both a branch and tag. This is - used for error condition testing. - - """ - # pylint: disable=R0913 - self._config.set(name, ExternalsDescription.TAG, tag) - - if repo_type: - repo_url = os.path.join('${MANIC_TEST_BARE_REPO_ROOT}', repo_type) - self._config.set(name, ExternalsDescription.REPO_URL, repo_url) - - try: - # remove the branch if it existed - if remove_branch: - self._config.remove_option(name, ExternalsDescription.BRANCH) - except BaseException: - pass - - self.write_config(dest_dir, filename) - - def update_underspecify_branch_tag(self, dest_dir, name, - filename=CFG_NAME): - """Update a repository protocol, and potentially the remote - """ - # pylint: disable=R0913 - try: - # remove the branch if it existed - self._config.remove_option(name, ExternalsDescription.BRANCH) - except BaseException: - pass - - try: - # remove the tag if it existed - self._config.remove_option(name, ExternalsDescription.TAG) - except BaseException: - pass - - self.write_config(dest_dir, filename) - - def update_underspecify_remove_url(self, dest_dir, name, - filename=CFG_NAME): - """Update a repository protocol, and potentially the remote - """ - # pylint: disable=R0913 - try: - # remove the repo url if it existed - self._config.remove_option(name, ExternalsDescription.REPO_URL) - except BaseException: - pass - - self.write_config(dest_dir, filename) - - def update_protocol(self, dest_dir, name, protocol, repo_type=None, - filename=CFG_NAME): - """Update a repository protocol, and potentially the remote - """ - # pylint: disable=R0913 - self._config.set(name, ExternalsDescription.PROTOCOL, protocol) - - if repo_type: - repo_url = os.path.join('${MANIC_TEST_BARE_REPO_ROOT}', repo_type) - self._config.set(name, ExternalsDescription.REPO_URL, repo_url) - - self.write_config(dest_dir, filename) - - -class BaseTestSysCheckout(unittest.TestCase): - """Base class of reusable systems level test setup for - checkout_externals - - """ - # NOTE(bja, 2017-11) pylint complains about long method names, but - # it is hard to differentiate tests without making them more - # cryptic. - # pylint: disable=invalid-name - - status_args = ['--status'] - checkout_args = [] - optional_args = ['--optional'] - verbose_args = ['--status', '--verbose'] - - def setUp(self): - """Setup for all individual checkout_externals tests - """ - # directory we want to return to after the test system and - # checkout_externals are done cd'ing all over the place. - self._return_dir = os.getcwd() - - self._test_id = self.id().split('.')[-1] - - # path to the executable - self._checkout = os.path.join('../checkout_externals') - self._checkout = os.path.abspath(self._checkout) - - # directory where we have test repositories - self._bare_root = os.path.join(os.getcwd(), BARE_REPO_ROOT_NAME) - self._bare_root = os.path.abspath(self._bare_root) - - # set into the environment so var will be expanded in externals files - os.environ[MANIC_TEST_BARE_REPO_ROOT] = self._bare_root - - # set the input file generator - self._generator = GenerateExternalsDescriptionCfgV1() - # set the input file generator for secondary externals - self._sub_generator = GenerateExternalsDescriptionCfgV1() - - def tearDown(self): - """Tear down for individual tests - """ - # remove the env var we added in setup - del os.environ[MANIC_TEST_BARE_REPO_ROOT] - - # return to our common starting point - os.chdir(self._return_dir) - - def setup_test_repo(self, parent_repo_name, dest_dir_in=None): - """Setup the paths and clone the base test repo - - """ - # unique repo for this test - test_dir_name = self._test_id - print("Test repository name: {0}".format(test_dir_name)) - - parent_repo_dir = os.path.join(self._bare_root, parent_repo_name) - if dest_dir_in is None: - dest_dir = os.path.join(os.environ[MANIC_TEST_TMP_REPO_ROOT], - test_dir_name) - else: - dest_dir = dest_dir_in - - # pylint: disable=W0212 - GitRepository._git_clone(parent_repo_dir, dest_dir, VERBOSITY_DEFAULT) - return dest_dir - - @staticmethod - def _add_file_to_repo(under_test_dir, filename, tracked): - """Add a file to the repository so we can put it into a dirty state - - """ - cwd = os.getcwd() - os.chdir(under_test_dir) - with open(filename, 'w') as tmp: - tmp.write('Hello, world!') - - if tracked: - # NOTE(bja, 2018-01) brittle hack to obtain repo dir and - # file name - path_data = filename.split('/') - repo_dir = os.path.join(path_data[0], path_data[1]) - os.chdir(repo_dir) - tracked_file = path_data[2] - cmd = ['git', 'add', tracked_file] - execute_subprocess(cmd) - - os.chdir(cwd) - - @staticmethod - def execute_cmd_in_dir(under_test_dir, args): - """Extecute the checkout command in the appropriate repo dir with the - specified additional args - - Note that we are calling the command line processing and main - routines and not using a subprocess call so that we get code - coverage results! - - """ - cwd = os.getcwd() - checkout_path = os.path.abspath('{0}/../../checkout_externals') - os.chdir(under_test_dir) - cmdline = ['--externals', CFG_NAME, ] - cmdline += args - repo_root = 'MANIC_TEST_BARE_REPO_ROOT={root}'.format( - root=os.environ[MANIC_TEST_BARE_REPO_ROOT]) - manual_cmd = ('Test cmd:\npushd {cwd}; {env} {checkout} {args}'.format( - cwd=under_test_dir, env=repo_root, checkout=checkout_path, - args=' '.join(cmdline))) - printlog(manual_cmd) - options = checkout.commandline_arguments(cmdline) - overall_status, tree_status = checkout.main(options) - os.chdir(cwd) - return overall_status, tree_status - - # ---------------------------------------------------------------- - # - # Check results for generic perturbation of states - # - # ---------------------------------------------------------------- - def _check_generic_empty_default_required(self, tree, name): - self.assertEqual(tree[name].sync_state, ExternalStatus.EMPTY) - self.assertEqual(tree[name].clean_state, ExternalStatus.DEFAULT) - self.assertEqual(tree[name].source_type, ExternalStatus.MANAGED) - - def _check_generic_ok_clean_required(self, tree, name): - self.assertEqual(tree[name].sync_state, ExternalStatus.STATUS_OK) - self.assertEqual(tree[name].clean_state, ExternalStatus.STATUS_OK) - self.assertEqual(tree[name].source_type, ExternalStatus.MANAGED) - - def _check_generic_ok_dirty_required(self, tree, name): - self.assertEqual(tree[name].sync_state, ExternalStatus.STATUS_OK) - self.assertEqual(tree[name].clean_state, ExternalStatus.DIRTY) - self.assertEqual(tree[name].source_type, ExternalStatus.MANAGED) - - def _check_generic_modified_ok_required(self, tree, name): - self.assertEqual(tree[name].sync_state, ExternalStatus.MODEL_MODIFIED) - self.assertEqual(tree[name].clean_state, ExternalStatus.STATUS_OK) - self.assertEqual(tree[name].source_type, ExternalStatus.MANAGED) - - def _check_generic_empty_default_optional(self, tree, name): - self.assertEqual(tree[name].sync_state, ExternalStatus.EMPTY) - self.assertEqual(tree[name].clean_state, ExternalStatus.DEFAULT) - self.assertEqual(tree[name].source_type, ExternalStatus.OPTIONAL) - - def _check_generic_ok_clean_optional(self, tree, name): - self.assertEqual(tree[name].sync_state, ExternalStatus.STATUS_OK) - self.assertEqual(tree[name].clean_state, ExternalStatus.STATUS_OK) - self.assertEqual(tree[name].source_type, ExternalStatus.OPTIONAL) - - # ---------------------------------------------------------------- - # - # Check results for individual named externals - # - # ---------------------------------------------------------------- - def _check_simple_tag_empty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_tag'.format(directory) - self._check_generic_empty_default_required(tree, name) - - def _check_simple_tag_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_tag'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_simple_tag_dirty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_tag'.format(directory) - self._check_generic_ok_dirty_required(tree, name) - - def _check_simple_tag_modified(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_tag'.format(directory) - self._check_generic_modified_ok_required(tree, name) - - def _check_simple_branch_empty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_branch'.format(directory) - self._check_generic_empty_default_required(tree, name) - - def _check_simple_branch_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_branch'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_simple_branch_modified(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_branch'.format(directory) - self._check_generic_modified_ok_required(tree, name) - - def _check_simple_hash_empty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_hash'.format(directory) - self._check_generic_empty_default_required(tree, name) - - def _check_simple_hash_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_hash'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_simple_hash_modified(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_hash'.format(directory) - self._check_generic_modified_ok_required(tree, name) - - def _check_simple_req_empty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_req'.format(directory) - self._check_generic_empty_default_required(tree, name) - - def _check_simple_req_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_req'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_simple_opt_empty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_opt'.format(directory) - self._check_generic_empty_default_optional(tree, name) - - def _check_simple_opt_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/simp_opt'.format(directory) - self._check_generic_ok_clean_optional(tree, name) - - def _check_mixed_ext_branch_empty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/mixed_req'.format(directory) - self._check_generic_empty_default_required(tree, name) - - def _check_mixed_ext_branch_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/mixed_req'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_mixed_ext_branch_modified(self, tree, directory=EXTERNALS_NAME): - name = './{0}/mixed_req'.format(directory) - self._check_generic_modified_ok_required(tree, name) - - # ---------------------------------------------------------------- - # - # Check results for groups of externals under specific conditions - # - # ---------------------------------------------------------------- - def _check_container_simple_required_pre_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_empty(tree) - self._check_simple_branch_empty(tree) - self._check_simple_hash_empty(tree) - - def _check_container_simple_required_checkout(self, overall, tree): - # Note, this is the internal tree status just before checkout - self.assertEqual(overall, 0) - self._check_simple_tag_empty(tree) - self._check_simple_branch_empty(tree) - self._check_simple_hash_empty(tree) - - def _check_container_simple_required_post_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_simple_branch_ok(tree) - self._check_simple_hash_ok(tree) - - def _check_container_simple_required_out_of_sync(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_modified(tree) - self._check_simple_branch_modified(tree) - self._check_simple_hash_modified(tree) - - def _check_container_simple_optional_pre_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_req_empty(tree) - self._check_simple_opt_empty(tree) - - def _check_container_simple_optional_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_req_empty(tree) - self._check_simple_opt_empty(tree) - - def _check_container_simple_optional_post_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_req_ok(tree) - self._check_simple_opt_empty(tree) - - def _check_container_simple_optional_post_optional(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_req_ok(tree) - self._check_simple_opt_ok(tree) - - def _check_container_simple_required_sb_modified(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_simple_branch_modified(tree) - self._check_simple_hash_ok(tree) - - def _check_container_simple_optional_st_dirty(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_dirty(tree) - self._check_simple_branch_ok(tree) - - def _check_container_full_pre_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_empty(tree) - self._check_simple_branch_empty(tree) - self._check_simple_opt_empty(tree) - self._check_mixed_ext_branch_required_pre_checkout(overall, tree) - - def _check_container_component_post_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_opt_ok(tree) - self._check_simple_tag_empty(tree) - self._check_simple_branch_empty(tree) - - def _check_container_component_post_checkout2(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_opt_ok(tree) - self._check_simple_tag_empty(tree) - self._check_simple_branch_ok(tree) - - def _check_container_full_post_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_simple_branch_ok(tree) - self._check_simple_opt_empty(tree) - self._check_mixed_ext_branch_required_post_checkout(overall, tree) - - def _check_container_full_pre_checkout_ext_change(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_simple_branch_ok(tree) - self._check_simple_opt_empty(tree) - self._check_mixed_ext_branch_required_pre_checkout_ext_change( - overall, tree) - - def _check_container_full_post_checkout_subext_modified( - self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_simple_branch_ok(tree) - self._check_simple_opt_empty(tree) - self._check_mixed_ext_branch_required_post_checkout_subext_modified( - overall, tree) - - def _check_mixed_ext_branch_required_pre_checkout(self, overall, tree): - # Note, this is the internal tree status just before checkout - self.assertEqual(overall, 0) - self._check_mixed_ext_branch_empty(tree, directory=EXTERNALS_NAME) - # NOTE: externals/mixed_req/src should not exist in the tree - # since this is the status before checkout of mixed_req. - - def _check_mixed_ext_branch_required_post_checkout(self, overall, tree): - # Note, this is the internal tree status just before checkout - self.assertEqual(overall, 0) - self._check_mixed_ext_branch_ok(tree, directory=EXTERNALS_NAME) - check_dir = "{0}/{1}/{2}".format(EXTERNALS_NAME, "mixed_req", - SUB_EXTERNALS_PATH) - self._check_simple_branch_ok(tree, directory=check_dir) - - def _check_mixed_ext_branch_required_pre_checkout_ext_change( - self, overall, tree): - # Note, this is the internal tree status just after change the - # externals description file, but before checkout - self.assertEqual(overall, 0) - self._check_mixed_ext_branch_modified(tree, directory=EXTERNALS_NAME) - check_dir = "{0}/{1}/{2}".format(EXTERNALS_NAME, "mixed_req", - SUB_EXTERNALS_PATH) - self._check_simple_branch_ok(tree, directory=check_dir) - - def _check_mixed_ext_branch_required_post_checkout_subext_modified( - self, overall, tree): - # Note, this is the internal tree status just after change the - # externals description file, but before checkout - self.assertEqual(overall, 0) - self._check_mixed_ext_branch_ok(tree, directory=EXTERNALS_NAME) - check_dir = "{0}/{1}/{2}".format(EXTERNALS_NAME, "mixed_req", - SUB_EXTERNALS_PATH) - self._check_simple_branch_modified(tree, directory=check_dir) - - def _check_mixed_cont_simple_required_pre_checkout(self, overall, tree): - # Note, this is the internal tree status just before checkout - self.assertEqual(overall, 0) - self._check_simple_tag_empty(tree, directory=EXTERNALS_NAME) - self._check_simple_branch_empty(tree, directory=EXTERNALS_NAME) - self._check_simple_branch_empty(tree, directory=SUB_EXTERNALS_PATH) - - def _check_mixed_cont_simple_required_checkout(self, overall, tree): - # Note, this is the internal tree status just before checkout - self.assertEqual(overall, 0) - self._check_simple_tag_empty(tree, directory=EXTERNALS_NAME) - self._check_simple_branch_empty(tree, directory=EXTERNALS_NAME) - self._check_simple_branch_empty(tree, directory=SUB_EXTERNALS_PATH) - - def _check_mixed_cont_simple_required_post_checkout(self, overall, tree): - # Note, this is the internal tree status just before checkout - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree, directory=EXTERNALS_NAME) - self._check_simple_branch_ok(tree, directory=EXTERNALS_NAME) - self._check_simple_branch_ok(tree, directory=SUB_EXTERNALS_PATH) - - -class TestSysCheckout(BaseTestSysCheckout): - """Run systems level tests of checkout_externals - - """ - # NOTE(bja, 2017-11) pylint complains about long method names, but - # it is hard to differentiate tests without making them more - # cryptic. - # pylint: disable=invalid-name - - # ---------------------------------------------------------------- - # - # Run systems tests - # - # ---------------------------------------------------------------- - def test_container_simple_required(self): - """Verify that a container with simple subrepos - generates the correct initial status. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # status of empty repo - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_pre_checkout(overall, tree) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # status clean checked out - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_simple_optional(self): - """Verify that container with an optional simple subrepos - generates the correct initial status. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_optional(under_test_dir) - - # check status of empty repo - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_optional_pre_checkout(overall, tree) - - # checkout required - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_optional_checkout(overall, tree) - - # status - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_optional_post_checkout(overall, tree) - - # checkout optional - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.optional_args) - self._check_container_simple_optional_post_checkout(overall, tree) - - # status - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_optional_post_optional(overall, tree) - - def test_container_simple_verbose(self): - """Verify that container with simple subrepos runs with verbose status - output and generates the correct initial status. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # check verbose status - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.verbose_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_simple_dirty(self): - """Verify that a container with simple subrepos - and a dirty status exits gracefully. - - """ - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # add a file to the repo - tracked = True - self._add_file_to_repo(under_test_dir, 'externals/simp_tag/tmp.txt', - tracked) - - # checkout: pre-checkout status should be dirty, did not - # modify working copy. - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_optional_st_dirty(overall, tree) - - # verify status is still dirty - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_optional_st_dirty(overall, tree) - - def test_container_simple_untracked(self): - """Verify that a container with simple subrepos and a untracked files - is not considered 'dirty' and will attempt an update. - - """ - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # add a file to the repo - tracked = False - self._add_file_to_repo(under_test_dir, 'externals/simp_tag/tmp.txt', - tracked) - - # checkout: pre-checkout status should be clean, ignoring the - # untracked file. - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_post_checkout(overall, tree) - - # verify status is still clean - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_simple_detached_sync(self): - """Verify that a container with simple subrepos generates the correct - out of sync status when making commits from a detached head - state. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # status of empty repo - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_pre_checkout(overall, tree) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # make a commit on the detached head of the tag and hash externals - self._generator.create_commit(under_test_dir, 'simp_tag') - self._generator.create_commit(under_test_dir, 'simp_hash') - self._generator.create_commit(under_test_dir, 'simp_branch') - - # status of repo, branch, tag and hash should all be out of sync! - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_out_of_sync(overall, tree) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - # same pre-checkout out of sync status - self._check_container_simple_required_out_of_sync(overall, tree) - - # now status should be in-sync - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_remote_branch(self): - """Verify that a container with remote branch change works - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # update the config file to point to a different remote with - # the same branch - self._generator.update_branch(under_test_dir, 'simp_branch', - REMOTE_BRANCH_FEATURE2, SIMPLE_FORK_NAME) - - # status of simp_branch should be out of sync - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_sb_modified(overall, tree) - - # checkout new externals - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_sb_modified(overall, tree) - - # status should be synced - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_remote_tag_same_branch(self): - """Verify that a container with remote tag change works. The new tag - should not be in the original repo, only the new remote - fork. The new tag is automatically fetched because it is on - the branch. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_tag(under_test_dir, 'simp_branch', - 'forked-feature-v1', SIMPLE_FORK_NAME) - - # status of simp_branch should be out of sync - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_sb_modified(overall, tree) - - # checkout new externals - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_sb_modified(overall, tree) - - # status should be synced - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_remote_tag_fetch_all(self): - """Verify that a container with remote tag change works. The new tag - should not be in the original repo, only the new remote - fork. It should also not be on a branch that will be fetch, - and therefore not fetched by default with 'git fetch'. It will - only be retreived by 'git fetch --tags' - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_tag(under_test_dir, 'simp_branch', - 'abandoned-feature', SIMPLE_FORK_NAME) - - # status of simp_branch should be out of sync - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_sb_modified(overall, tree) - - # checkout new externals - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_sb_modified(overall, tree) - - # status should be synced - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_preserve_dot(self): - """Verify that after inital checkout, modifying an external git repo - url to '.' and the current branch will leave it unchanged. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_required_checkout(overall, tree) - - # update the config file to point to a different remote with - # the same branch - self._generator.update_branch(under_test_dir, 'simp_branch', - REMOTE_BRANCH_FEATURE2, SIMPLE_FORK_NAME) - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - - # verify status is clean and unmodified - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - # update branch to point to a new branch that only exists in - # the local fork - self._generator.create_branch(under_test_dir, 'simp_branch', - 'private-feature', with_commit=True) - self._generator.update_branch(under_test_dir, 'simp_branch', - 'private-feature', - SIMPLE_LOCAL_ONLY_NAME) - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - - # verify status is clean and unmodified - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_required_post_checkout(overall, tree) - - def test_container_full(self): - """Verify that 'full' container with simple and mixed subrepos - generates the correct initial status. - - The mixed subrepo has a sub-externals file with different - sub-externals on different branches. - - """ - # create the test repository - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - - # create the top level externals file - self._generator.container_full(under_test_dir) - - # inital checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_full_pre_checkout(overall, tree) - - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_full_post_checkout(overall, tree) - - # update the mixed-use repo to point to different branch - self._generator.update_branch(under_test_dir, 'mixed_req', - 'new-feature', MIXED_REPO_NAME) - - # check status out of sync for mixed_req, but sub-externals - # are still in sync - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_full_pre_checkout_ext_change(overall, tree) - - # run the checkout. Now the mixed use external and it's - # sub-exterals should be changed. Returned status is - # pre-checkout! - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_full_pre_checkout_ext_change(overall, tree) - - # check status out of sync for mixed_req, and sub-externals - # are in sync. - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_full_post_checkout(overall, tree) - - def test_container_component(self): - """Verify that optional component checkout works - """ - # create the test repository - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - - # create the top level externals file - self._generator.container_full(under_test_dir) - - # inital checkout, first try a nonexistant component argument noref - checkout_args = ['simp_opt', 'noref'] - checkout_args.extend(self.checkout_args) - - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, checkout_args) - - checkout_args = ['simp_opt'] - checkout_args.extend(self.checkout_args) - - overall, tree = self.execute_cmd_in_dir(under_test_dir, - checkout_args) - - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_component_post_checkout(overall, tree) - checkout_args.append('simp_branch') - overall, tree = self.execute_cmd_in_dir(under_test_dir, - checkout_args) - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_component_post_checkout2(overall, tree) - - def test_mixed_simple(self): - """Verify that a mixed use repo can serve as a 'full' container, - pulling in a set of externals and a seperate set of sub-externals. - - """ - #import pdb; pdb.set_trace() - # create repository - under_test_dir = self.setup_test_repo(MIXED_REPO_NAME) - # create top level externals file - self._generator.mixed_simple_base(under_test_dir) - # NOTE: sub-externals file is already in the repo so we can - # switch branches during testing. Since this is a mixed-repo - # serving as the top level container repo, we can't switch - # during this test. - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_mixed_cont_simple_required_checkout(overall, tree) - - # verify status is clean and unmodified - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_mixed_cont_simple_required_post_checkout(overall, tree) - - -class TestSysCheckoutSVN(BaseTestSysCheckout): - """Run systems level tests of checkout_externals accessing svn repositories - - SVN tests - these tests use the svn repository interface. Since - they require an active network connection, they are significantly - slower than the git tests. But svn testing is critical. So try to - design the tests to only test svn repository functionality - (checkout, switch) and leave generic testing of functionality like - 'optional' to the fast git tests. - - Example timing as of 2017-11: - - * All other git and unit tests combined take between 4-5 seconds - - * Just checking if svn is available for a single test takes 2 seconds. - - * The single svn test typically takes between 10 and 25 seconds - (depending on the network)! - - NOTE(bja, 2017-11) To enable CI testing we can't use a real remote - repository that restricts access and it seems inappropriate to hit - a random open source repo. For now we are just hitting one of our - own github repos using the github svn server interface. This - should be "good enough" for basic checkout and swich - functionality. But if additional svn functionality is required, a - better solution will be necessary. I think eventually we want to - create a small local svn repository on the fly (doesn't require an - svn server or network connection!) and use it for testing. - - """ - - def _check_svn_branch_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/svn_branch'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_svn_branch_dirty(self, tree, directory=EXTERNALS_NAME): - name = './{0}/svn_branch'.format(directory) - self._check_generic_ok_dirty_required(tree, name) - - def _check_svn_tag_ok(self, tree, directory=EXTERNALS_NAME): - name = './{0}/svn_tag'.format(directory) - self._check_generic_ok_clean_required(tree, name) - - def _check_svn_tag_modified(self, tree, directory=EXTERNALS_NAME): - name = './{0}/svn_tag'.format(directory) - self._check_generic_modified_ok_required(tree, name) - - def _check_container_simple_svn_post_checkout(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_svn_branch_ok(tree) - self._check_svn_tag_ok(tree) - - def _check_container_simple_svn_sb_dirty_st_mod(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_svn_tag_modified(tree) - self._check_svn_branch_dirty(tree) - - def _check_container_simple_svn_sb_clean_st_mod(self, overall, tree): - self.assertEqual(overall, 0) - self._check_simple_tag_ok(tree) - self._check_svn_tag_modified(tree) - self._check_svn_branch_ok(tree) - - @staticmethod - def have_svn_access(): - """Check if we have svn access so we can enable tests that use svn. - - """ - have_svn = False - cmd = ['svn', 'ls', SVN_TEST_REPO, ] - try: - execute_subprocess(cmd) - have_svn = True - except BaseException: - pass - return have_svn - - def skip_if_no_svn_access(self): - """Function decorator to disable svn tests when svn isn't available - """ - have_svn = self.have_svn_access() - if not have_svn: - raise unittest.SkipTest("No svn access") - - def test_container_simple_svn(self): - """Verify that a container repo can pull in an svn branch and svn tag. - - """ - self.skip_if_no_svn_access() - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_svn(under_test_dir) - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - - # verify status is clean and unmodified - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_svn_post_checkout(overall, tree) - - # update description file to make the tag into a branch and - # trigger a switch - self._generator.update_svn_branch(under_test_dir, 'svn_tag', 'trunk') - - # checkout - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - - # verify status is clean and unmodified - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.status_args) - self._check_container_simple_svn_post_checkout(overall, tree) - - # add an untracked file to the repo - tracked = False - self._add_file_to_repo(under_test_dir, - 'externals/svn_branch/tmp.txt', tracked) - - # run a no-op checkout: pre-checkout status should be clean, - # ignoring the untracked file. - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_svn_post_checkout(overall, tree) - - # update description file to make the branch into a tag and - # trigger a modified sync status - self._generator.update_svn_branch(under_test_dir, 'svn_tag', - 'tags/cesm2.0.beta07') - - # checkout: pre-checkout status should be clean and modified, - # will modify working copy. - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.checkout_args) - self._check_container_simple_svn_sb_clean_st_mod(overall, tree) - - # verify status is still clean and unmodified, last - # checkout modified the working dir state. - overall, tree = self.execute_cmd_in_dir(under_test_dir, - self.verbose_args) - self._check_container_simple_svn_post_checkout(overall, tree) - -class TestSubrepoCheckout(BaseTestSysCheckout): - # Need to store information at setUp time for checking - # pylint: disable=too-many-instance-attributes - """Run tests to ensure proper handling of repos with submodules. - - By default, submodules in git repositories are checked out. A git - repository checked out as a submodule is treated as if it was - listed in an external with the same properties as in the source - .gitmodules file. - """ - - def setUp(self): - """Setup for all submodule checkout tests - Create a repo with two submodule repositories. - """ - - # Run the basic setup - super(TestSubrepoCheckout, self).setUp() - # create test repo - # We need to do this here (rather than have a static repo) because - # git submodules do not allow for variables in .gitmodules files - self._test_repo_name = 'test_repo_with_submodules' - self._bare_branch_name = 'subrepo_branch' - self._config_branch_name = 'subrepo_config_branch' - self._container_extern_name = 'externals_container.cfg' - self._my_test_dir = os.path.join(os.environ[MANIC_TEST_TMP_REPO_ROOT], - self._test_id) - self._repo_dir = os.path.join(self._my_test_dir, self._test_repo_name) - self._checkout_dir = 'repo_with_submodules' - check_dir = self.setup_test_repo(CONTAINER_REPO_NAME, - dest_dir_in=self._repo_dir) - self.assertTrue(self._repo_dir == check_dir) - # Add the submodules - cwd = os.getcwd() - fork_repo_dir = os.path.join(self._bare_root, SIMPLE_FORK_NAME) - simple_repo_dir = os.path.join(self._bare_root, SIMPLE_REPO_NAME) - self._simple_ext_fork_name = SIMPLE_FORK_NAME.split('.')[0] - self._simple_ext_name = SIMPLE_REPO_NAME.split('.')[0] - os.chdir(self._repo_dir) - # Add a branch with a subrepo - cmd = ['git', 'branch', self._bare_branch_name, 'master'] - execute_subprocess(cmd) - cmd = ['git', 'checkout', self._bare_branch_name] - execute_subprocess(cmd) - cmd = ['git', 'submodule', 'add', fork_repo_dir] - execute_subprocess(cmd) - cmd = ['git', 'commit', '-am', "'Added simple-ext-fork as a submodule'"] - execute_subprocess(cmd) - # Save the fork repo hash for comparison - os.chdir(self._simple_ext_fork_name) - self._fork_hash_check = self.get_git_hash() - os.chdir(self._repo_dir) - # Now, create a branch to test from_sbmodule - cmd = ['git', 'branch', - self._config_branch_name, self._bare_branch_name] - execute_subprocess(cmd) - cmd = ['git', 'checkout', self._config_branch_name] - execute_subprocess(cmd) - cmd = ['git', 'submodule', 'add', simple_repo_dir] - execute_subprocess(cmd) - # Checkout feature2 - os.chdir(self._simple_ext_name) - cmd = ['git', 'branch', 'feature2', 'origin/feature2'] - execute_subprocess(cmd) - cmd = ['git', 'checkout', 'feature2'] - execute_subprocess(cmd) - # Save the fork repo hash for comparison - self._simple_hash_check = self.get_git_hash() - os.chdir(self._repo_dir) - self.create_externals_file(filename=self._container_extern_name, - dest_dir=self._repo_dir, from_submodule=True) - cmd = ['git', 'add', self._container_extern_name] - execute_subprocess(cmd) - cmd = ['git', 'commit', '-am', "'Added simple-ext as a submodule'"] - execute_subprocess(cmd) - # Reset to master - cmd = ['git', 'checkout', 'master'] - execute_subprocess(cmd) - os.chdir(cwd) - - @staticmethod - def get_git_hash(revision="HEAD"): - """Return the hash for """ - cmd = ['git', 'rev-parse', revision] - git_out = execute_subprocess(cmd, output_to_caller=True) - return git_out.strip() - - def create_externals_file(self, name='', filename=CFG_NAME, dest_dir=None, - branch_name=None, sub_externals=None, - from_submodule=False): - # pylint: disable=too-many-arguments - """Create a container externals file with only simple externals. - - """ - self._generator.create_config() - - if dest_dir is None: - dest_dir = self._my_test_dir - - if from_submodule: - self._generator.create_section(SIMPLE_FORK_NAME, - self._simple_ext_fork_name, - from_submodule=True) - self._generator.create_section(SIMPLE_REPO_NAME, - self._simple_ext_name, - branch='feature3', path='', - from_submodule=False) - else: - if branch_name is None: - branch_name = 'master' - - self._generator.create_section(self._test_repo_name, - self._checkout_dir, - branch=branch_name, - path=name, externals=sub_externals, - repo_path=self._repo_dir) - - self._generator.write_config(dest_dir, filename=filename) - - def idempotence_check(self, checkout_dir): - """Verify that calling checkout_externals and - checkout_externals --status does not cause errors""" - cwd = os.getcwd() - os.chdir(checkout_dir) - overall, _ = self.execute_cmd_in_dir(self._my_test_dir, - self.checkout_args) - self.assertTrue(overall == 0) - overall, _ = self.execute_cmd_in_dir(self._my_test_dir, - self.status_args) - self.assertTrue(overall == 0) - os.chdir(cwd) - - def test_submodule_checkout_bare(self): - """Verify that a git repo with submodule is properly checked out - This test if for where there is no 'externals' keyword in the - parent repo. - Correct behavior is that the submodule is checked out using - normal git submodule behavior. - """ - simple_ext_fork_tag = "(tag1)" - simple_ext_fork_status = " " - self.create_externals_file(branch_name=self._bare_branch_name) - overall, _ = self.execute_cmd_in_dir(self._my_test_dir, - self.checkout_args) - self.assertTrue(overall == 0) - cwd = os.getcwd() - checkout_dir = os.path.join(self._my_test_dir, self._checkout_dir) - fork_file = os.path.join(checkout_dir, - self._simple_ext_fork_name, "readme.txt") - self.assertTrue(os.path.exists(fork_file)) - os.chdir(checkout_dir) - submods = git_submodule_status(checkout_dir) - self.assertEqual(len(submods.keys()), 1) - self.assertTrue(self._simple_ext_fork_name in submods) - submod = submods[self._simple_ext_fork_name] - self.assertTrue('hash' in submod) - self.assertEqual(submod['hash'], self._fork_hash_check) - self.assertTrue('status' in submod) - self.assertEqual(submod['status'], simple_ext_fork_status) - self.assertTrue('tag' in submod) - self.assertEqual(submod['tag'], simple_ext_fork_tag) - os.chdir(cwd) - self.idempotence_check(checkout_dir) - - def test_submodule_checkout_none(self): - """Verify that a git repo with submodule is properly checked out - This test is for when 'externals=None' is in parent repo's - externals cfg file. - Correct behavior is the submodle is not checked out. - """ - self.create_externals_file(branch_name=self._bare_branch_name, - sub_externals="none") - overall, _ = self.execute_cmd_in_dir(self._my_test_dir, - self.checkout_args) - self.assertTrue(overall == 0) - cwd = os.getcwd() - checkout_dir = os.path.join(self._my_test_dir, self._checkout_dir) - fork_file = os.path.join(checkout_dir, - self._simple_ext_fork_name, "readme.txt") - self.assertFalse(os.path.exists(fork_file)) - os.chdir(cwd) - self.idempotence_check(checkout_dir) - - def test_submodule_checkout_config(self): # pylint: disable=too-many-locals - """Verify that a git repo with submodule is properly checked out - This test if for when the 'from_submodule' keyword is used in the - parent repo. - Correct behavior is that the submodule is checked out using - normal git submodule behavior. - """ - tag_check = None # Not checked out as submodule - status_check = "-" # Not checked out as submodule - self.create_externals_file(branch_name=self._config_branch_name, - sub_externals=self._container_extern_name) - overall, _ = self.execute_cmd_in_dir(self._my_test_dir, - self.checkout_args) - self.assertTrue(overall == 0) - cwd = os.getcwd() - checkout_dir = os.path.join(self._my_test_dir, self._checkout_dir) - fork_file = os.path.join(checkout_dir, - self._simple_ext_fork_name, "readme.txt") - self.assertTrue(os.path.exists(fork_file)) - os.chdir(checkout_dir) - # Check submodule status - submods = git_submodule_status(checkout_dir) - self.assertEqual(len(submods.keys()), 2) - self.assertTrue(self._simple_ext_fork_name in submods) - submod = submods[self._simple_ext_fork_name] - self.assertTrue('hash' in submod) - self.assertEqual(submod['hash'], self._fork_hash_check) - self.assertTrue('status' in submod) - self.assertEqual(submod['status'], status_check) - self.assertTrue('tag' in submod) - self.assertEqual(submod['tag'], tag_check) - self.assertTrue(self._simple_ext_name in submods) - submod = submods[self._simple_ext_name] - self.assertTrue('hash' in submod) - self.assertEqual(submod['hash'], self._simple_hash_check) - self.assertTrue('status' in submod) - self.assertEqual(submod['status'], status_check) - self.assertTrue('tag' in submod) - self.assertEqual(submod['tag'], tag_check) - # Check fork repo status - os.chdir(self._simple_ext_fork_name) - self.assertEqual(self.get_git_hash(), self._fork_hash_check) - os.chdir(checkout_dir) - os.chdir(self._simple_ext_name) - hash_check = self.get_git_hash('origin/feature3') - self.assertEqual(self.get_git_hash(), hash_check) - os.chdir(cwd) - self.idempotence_check(checkout_dir) - -class TestSysCheckoutErrors(BaseTestSysCheckout): - """Run systems level tests of error conditions in checkout_externals - - Error conditions - these tests are designed to trigger specific - error conditions and ensure that they are being handled as - runtime errors (and hopefully usefull error messages) instead of - the default internal message that won't mean anything to the - user, e.g. key error, called process error, etc. - - These are not 'expected failures'. They are pass when a - RuntimeError is raised, fail if any other error is raised (or no - error is raised). - - """ - - # NOTE(bja, 2017-11) pylint complains about long method names, but - # it is hard to differentiate tests without making them more - # cryptic. - # pylint: disable=invalid-name - - def test_error_unknown_protocol(self): - """Verify that a runtime error is raised when the user specified repo - protocol is not known. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_protocol(under_test_dir, 'simp_branch', - 'this-protocol-does-not-exist') - - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, self.checkout_args) - - def test_error_switch_protocol(self): - """Verify that a runtime error is raised when the user switches - protocols, git to svn. - - TODO(bja, 2017-11) This correctly results in an error, but it - isn't a helpful error message. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_protocol(under_test_dir, 'simp_branch', 'svn') - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, self.checkout_args) - - def test_error_unknown_tag(self): - """Verify that a runtime error is raised when the user specified tag - does not exist. - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_tag(under_test_dir, 'simp_branch', - 'this-tag-does-not-exist', SIMPLE_REPO_NAME) - - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, self.checkout_args) - - def test_error_overspecify_tag_branch(self): - """Verify that a runtime error is raised when the user specified both - tag and a branch - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_tag(under_test_dir, 'simp_branch', - 'this-tag-does-not-exist', SIMPLE_REPO_NAME, - remove_branch=False) - - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, self.checkout_args) - - def test_error_underspecify_tag_branch(self): - """Verify that a runtime error is raised when the user specified - neither a tag or a branch - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_underspecify_branch_tag(under_test_dir, - 'simp_branch') - - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, self.checkout_args) - - def test_error_missing_url(self): - """Verify that a runtime error is raised when the user specified - neither a tag or a branch - - """ - # create repo - under_test_dir = self.setup_test_repo(CONTAINER_REPO_NAME) - self._generator.container_simple_required(under_test_dir) - - # update the config file to point to a different remote with - # the tag instead of branch. Tag MUST NOT be in the original - # repo! - self._generator.update_underspecify_remove_url(under_test_dir, - 'simp_branch') - - with self.assertRaises(RuntimeError): - self.execute_cmd_in_dir(under_test_dir, self.checkout_args) - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_sys_repository_git.py b/manage_externals/test/test_sys_repository_git.py deleted file mode 100644 index f6dbf8428..000000000 --- a/manage_externals/test/test_sys_repository_git.py +++ /dev/null @@ -1,238 +0,0 @@ -#!/usr/bin/env python - -"""Tests of some of the functionality in repository_git.py that actually -interacts with git repositories. - -We're calling these "system" tests because we expect them to be a lot -slower than most of the unit tests. - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import os -import shutil -import tempfile -import unittest - -from manic.repository_git import GitRepository -from manic.externals_description import ExternalsDescription -from manic.externals_description import ExternalsDescriptionDict -from manic.utils import execute_subprocess - -# NOTE(wjs, 2018-04-09) I find a mix of camel case and underscores to be -# more readable for unit test names, so I'm disabling pylint's naming -# convention check -# pylint: disable=C0103 - -# Allow access to protected members -# pylint: disable=W0212 - - -class GitTestCase(unittest.TestCase): - """Adds some git-specific unit test functionality on top of TestCase""" - - def assertIsHash(self, maybe_hash): - """Assert that the string given by maybe_hash really does look - like a git hash. - """ - - # Ensure it is non-empty - self.assertTrue(maybe_hash, msg="maybe_hash is empty") - - # Ensure it has a single string - self.assertEqual(1, len(maybe_hash.split()), - msg="maybe_hash has multiple strings: {}".format(maybe_hash)) - - # Ensure that the only characters in the string are ones allowed - # in hashes - allowed_chars_set = set('0123456789abcdef') - self.assertTrue(set(maybe_hash) <= allowed_chars_set, - msg="maybe_hash has non-hash characters: {}".format(maybe_hash)) - - -class TestGitTestCase(GitTestCase): - """Tests GitTestCase""" - - def test_assertIsHash_true(self): - """Ensure that assertIsHash passes for something that looks - like a hash""" - self.assertIsHash('abc123') - - def test_assertIsHash_empty(self): - """Ensure that assertIsHash raises an AssertionError for an - empty string""" - with self.assertRaises(AssertionError): - self.assertIsHash('') - - def test_assertIsHash_multipleStrings(self): - """Ensure that assertIsHash raises an AssertionError when - given multiple strings""" - with self.assertRaises(AssertionError): - self.assertIsHash('abc123 def456') - - def test_assertIsHash_badChar(self): - """Ensure that assertIsHash raises an AssertionError when given a - string that has a character that doesn't belong in a hash - """ - with self.assertRaises(AssertionError): - self.assertIsHash('abc123g') - - -class TestGitRepositoryGitCommands(GitTestCase): - """Test some git commands in RepositoryGit - - It's silly that we need to create a repository in order to test - these git commands. Much or all of the git functionality that is - currently in repository_git.py should eventually be moved to a - separate module that is solely responsible for wrapping git - commands; that would allow us to test it independently of this - repository class. - """ - - # ======================================================================== - # Test helper functions - # ======================================================================== - - def setUp(self): - # directory we want to return to after the test system and - # checkout_externals are done cd'ing all over the place. - self._return_dir = os.getcwd() - - self._tmpdir = tempfile.mkdtemp() - os.chdir(self._tmpdir) - - self._name = 'component' - rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: - '/path/to/local/repo', - ExternalsDescription.TAG: - 'tag1', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: 'junk', - ExternalsDescription.EXTERNALS: '', - ExternalsDescription.REPO: rdata, - }, - } - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = GitRepository('test', repo) - - def tearDown(self): - # return to our common starting point - os.chdir(self._return_dir) - - shutil.rmtree(self._tmpdir, ignore_errors=True) - - @staticmethod - def make_git_repo(): - """Turn the current directory into an empty git repository""" - execute_subprocess(['git', 'init']) - - @staticmethod - def add_git_commit(): - """Add a git commit in the current directory""" - with open('README', 'a') as myfile: - myfile.write('more info') - execute_subprocess(['git', 'add', 'README']) - execute_subprocess(['git', 'commit', '-m', 'my commit message']) - - @staticmethod - def checkout_git_branch(branchname): - """Checkout a new branch in the current directory""" - execute_subprocess(['git', 'checkout', '-b', branchname]) - - @staticmethod - def make_git_tag(tagname): - """Make a lightweight tag at the current commit""" - execute_subprocess(['git', 'tag', '-m', 'making a tag', tagname]) - - @staticmethod - def checkout_ref(refname): - """Checkout the given refname in the current directory""" - execute_subprocess(['git', 'checkout', refname]) - - # ======================================================================== - # Begin actual tests - # ======================================================================== - - def test_currentHash_returnsHash(self): - """Ensure that the _git_current_hash function returns a hash""" - self.make_git_repo() - self.add_git_commit() - hash_found, myhash = self._repo._git_current_hash() - self.assertTrue(hash_found) - self.assertIsHash(myhash) - - def test_currentHash_outsideGitRepo(self): - """Ensure that the _git_current_hash function returns False when - outside a git repository""" - hash_found, myhash = self._repo._git_current_hash() - self.assertFalse(hash_found) - self.assertEqual('', myhash) - - def test_currentBranch_onBranch(self): - """Ensure that the _git_current_branch function returns the name - of the branch""" - self.make_git_repo() - self.add_git_commit() - self.checkout_git_branch('foo') - branch_found, mybranch = self._repo._git_current_branch() - self.assertTrue(branch_found) - self.assertEqual('foo', mybranch) - - def test_currentBranch_notOnBranch(self): - """Ensure that the _git_current_branch function returns False - when not on a branch""" - self.make_git_repo() - self.add_git_commit() - self.make_git_tag('mytag') - self.checkout_ref('mytag') - branch_found, mybranch = self._repo._git_current_branch() - self.assertFalse(branch_found) - self.assertEqual('', mybranch) - - def test_currentBranch_outsideGitRepo(self): - """Ensure that the _git_current_branch function returns False - when outside a git repository""" - branch_found, mybranch = self._repo._git_current_branch() - self.assertFalse(branch_found) - self.assertEqual('', mybranch) - - def test_currentTag_onTag(self): - """Ensure that the _git_current_tag function returns the name of - the tag""" - self.make_git_repo() - self.add_git_commit() - self.make_git_tag('some_tag') - tag_found, mytag = self._repo._git_current_tag() - self.assertTrue(tag_found) - self.assertEqual('some_tag', mytag) - - def test_currentTag_notOnTag(self): - """Ensure tha the _git_current_tag function returns False when - not on a tag""" - self.make_git_repo() - self.add_git_commit() - self.make_git_tag('some_tag') - self.add_git_commit() - tag_found, mytag = self._repo._git_current_tag() - self.assertFalse(tag_found) - self.assertEqual('', mytag) - - def test_currentTag_outsideGitRepo(self): - """Ensure that the _git_current_tag function returns False when - outside a git repository""" - tag_found, mytag = self._repo._git_current_tag() - self.assertFalse(tag_found) - self.assertEqual('', mytag) - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_unit_externals_description.py b/manage_externals/test/test_unit_externals_description.py deleted file mode 100644 index 637f760ee..000000000 --- a/manage_externals/test/test_unit_externals_description.py +++ /dev/null @@ -1,401 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for checkout_externals - -Note: this script assume the path to the checkout_externals.py module is -already in the python path. - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import os -import os.path -import shutil -import unittest - -try: - # python2 - from ConfigParser import SafeConfigParser as config_parser - - def config_string_cleaner(text): - """convert strings into unicode - """ - return text.decode('utf-8') -except ImportError: - # python3 - from configparser import ConfigParser as config_parser - - def config_string_cleaner(text): - """Python3 already uses unicode strings, so just return the string - without modification. - - """ - return text - -from manic.externals_description import DESCRIPTION_SECTION, VERSION_ITEM -from manic.externals_description import ExternalsDescription -from manic.externals_description import ExternalsDescriptionDict -from manic.externals_description import ExternalsDescriptionConfigV1 -from manic.externals_description import get_cfg_schema_version -from manic.externals_description import read_externals_description_file -from manic.externals_description import create_externals_description - -from manic.global_constants import EMPTY_STR - - -class TestCfgSchemaVersion(unittest.TestCase): - """Test that schema identification for the externals description - returns the correct results. - - """ - - def setUp(self): - """Reusable config object - """ - self._config = config_parser() - self._config.add_section('section1') - self._config.set('section1', 'keword', 'value') - - self._config.add_section(DESCRIPTION_SECTION) - - def test_schema_version_valid(self): - """Test that schema identification returns the correct version for a - valid tag. - - """ - version_str = '2.1.3' - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, version_str) - major, minor, patch = get_cfg_schema_version(self._config) - expected_major = 2 - expected_minor = 1 - expected_patch = 3 - self.assertEqual(expected_major, major) - self.assertEqual(expected_minor, minor) - self.assertEqual(expected_patch, patch) - - def test_schema_section_missing(self): - """Test that an error is returned if the schema section is missing - from the input file. - - """ - self._config.remove_section(DESCRIPTION_SECTION) - with self.assertRaises(RuntimeError): - get_cfg_schema_version(self._config) - - def test_schema_version_missing(self): - """Test that a externals description file without a version raises a - runtime error. - - """ - # Note: the default setup method shouldn't include a version - # keyword, but remove it just to be future proof.... - self._config.remove_option(DESCRIPTION_SECTION, VERSION_ITEM) - with self.assertRaises(RuntimeError): - get_cfg_schema_version(self._config) - - def test_schema_version_not_int(self): - """Test that a externals description file a version that doesn't - decompose to integer major, minor and patch versions raises - runtime error. - - """ - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, 'unknown') - with self.assertRaises(RuntimeError): - get_cfg_schema_version(self._config) - - -class TestModelDescritionConfigV1(unittest.TestCase): - """Test that parsing config/ini fileproduces a correct dictionary - for the externals description. - - """ - # pylint: disable=R0902 - - def setUp(self): - """Boiler plate construction of string containing xml for multiple components. - """ - self._comp1_name = 'comp1' - self._comp1_path = 'path/to/comp1' - self._comp1_protocol = 'svn' - self._comp1_url = 'https://svn.somewhere.com/path/of/comp1' - self._comp1_tag = 'a_nice_tag_v1' - self._comp1_is_required = 'True' - self._comp1_externals = '' - - self._comp2_name = 'comp2' - self._comp2_path = 'path/to/comp2' - self._comp2_protocol = 'git' - self._comp2_url = '/local/clone/of/comp2' - self._comp2_branch = 'a_very_nice_branch' - self._comp2_is_required = 'False' - self._comp2_externals = 'path/to/comp2.cfg' - - def _setup_comp1(self, config): - """Boiler plate construction of xml string for componet 1 - """ - config.add_section(self._comp1_name) - config.set(self._comp1_name, 'local_path', self._comp1_path) - config.set(self._comp1_name, 'protocol', self._comp1_protocol) - config.set(self._comp1_name, 'repo_url', self._comp1_url) - config.set(self._comp1_name, 'tag', self._comp1_tag) - config.set(self._comp1_name, 'required', self._comp1_is_required) - - def _setup_comp2(self, config): - """Boiler plate construction of xml string for componet 2 - """ - config.add_section(self._comp2_name) - config.set(self._comp2_name, 'local_path', self._comp2_path) - config.set(self._comp2_name, 'protocol', self._comp2_protocol) - config.set(self._comp2_name, 'repo_url', self._comp2_url) - config.set(self._comp2_name, 'branch', self._comp2_branch) - config.set(self._comp2_name, 'required', self._comp2_is_required) - config.set(self._comp2_name, 'externals', self._comp2_externals) - - @staticmethod - def _setup_externals_description(config): - """Add the required exernals description section - """ - - config.add_section(DESCRIPTION_SECTION) - config.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.0.1') - - def _check_comp1(self, model): - """Test that component one was constructed correctly. - """ - self.assertTrue(self._comp1_name in model) - comp1 = model[self._comp1_name] - self.assertEqual(comp1[ExternalsDescription.PATH], self._comp1_path) - self.assertTrue(comp1[ExternalsDescription.REQUIRED]) - repo = comp1[ExternalsDescription.REPO] - self.assertEqual(repo[ExternalsDescription.PROTOCOL], - self._comp1_protocol) - self.assertEqual(repo[ExternalsDescription.REPO_URL], self._comp1_url) - self.assertEqual(repo[ExternalsDescription.TAG], self._comp1_tag) - self.assertEqual(EMPTY_STR, comp1[ExternalsDescription.EXTERNALS]) - - def _check_comp2(self, model): - """Test that component two was constucted correctly. - """ - self.assertTrue(self._comp2_name in model) - comp2 = model[self._comp2_name] - self.assertEqual(comp2[ExternalsDescription.PATH], self._comp2_path) - self.assertFalse(comp2[ExternalsDescription.REQUIRED]) - repo = comp2[ExternalsDescription.REPO] - self.assertEqual(repo[ExternalsDescription.PROTOCOL], - self._comp2_protocol) - self.assertEqual(repo[ExternalsDescription.REPO_URL], self._comp2_url) - self.assertEqual(repo[ExternalsDescription.BRANCH], self._comp2_branch) - self.assertEqual(self._comp2_externals, - comp2[ExternalsDescription.EXTERNALS]) - - def test_one_tag_required(self): - """Test that a component source with a tag is correctly parsed. - """ - config = config_parser() - self._setup_comp1(config) - self._setup_externals_description(config) - model = ExternalsDescriptionConfigV1(config) - print(model) - self._check_comp1(model) - - def test_one_branch_externals(self): - """Test that a component source with a branch is correctly parsed. - """ - config = config_parser() - self._setup_comp2(config) - self._setup_externals_description(config) - model = ExternalsDescriptionConfigV1(config) - print(model) - self._check_comp2(model) - - def test_two_sources(self): - """Test that multiple component sources are correctly parsed. - """ - config = config_parser() - self._setup_comp1(config) - self._setup_comp2(config) - self._setup_externals_description(config) - model = ExternalsDescriptionConfigV1(config) - print(model) - self._check_comp1(model) - self._check_comp2(model) - - def test_cfg_v1_reject_unknown_item(self): - """Test that a v1 description object will reject unknown items - """ - config = config_parser() - self._setup_comp1(config) - self._setup_externals_description(config) - config.set(self._comp1_name, 'junk', 'foobar') - with self.assertRaises(RuntimeError): - ExternalsDescriptionConfigV1(config) - - def test_cfg_v1_reject_v2(self): - """Test that a v1 description object won't try to parse a v2 file. - """ - config = config_parser() - self._setup_comp1(config) - self._setup_externals_description(config) - config.set(DESCRIPTION_SECTION, VERSION_ITEM, '2.0.1') - with self.assertRaises(RuntimeError): - ExternalsDescriptionConfigV1(config) - - def test_cfg_v1_reject_v1_too_new(self): - """Test that a v1 description object won't try to parse a v2 file. - """ - config = config_parser() - self._setup_comp1(config) - self._setup_externals_description(config) - config.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.100.0') - with self.assertRaises(RuntimeError): - ExternalsDescriptionConfigV1(config) - - -class TestReadExternalsDescription(unittest.TestCase): - """Test the application logic of read_externals_description_file - """ - TMP_FAKE_DIR = 'fake' - - def setUp(self): - """Setup directory for tests - """ - if not os.path.exists(self.TMP_FAKE_DIR): - os.makedirs(self.TMP_FAKE_DIR) - - def tearDown(self): - """Cleanup tmp stuff on the file system - """ - if os.path.exists(self.TMP_FAKE_DIR): - shutil.rmtree(self.TMP_FAKE_DIR) - - def test_no_file_error(self): - """Test that a runtime error is raised when the file does not exist - - """ - root_dir = os.getcwd() - filename = 'this-file-should-not-exist' - with self.assertRaises(RuntimeError): - read_externals_description_file(root_dir, filename) - - def test_no_dir_error(self): - """Test that a runtime error is raised when the file does not exist - - """ - root_dir = '/path/to/some/repo' - filename = 'externals.cfg' - with self.assertRaises(RuntimeError): - read_externals_description_file(root_dir, filename) - - def test_no_invalid_error(self): - """Test that a runtime error is raised when the file format is invalid - - """ - root_dir = os.getcwd() - filename = 'externals.cfg' - file_path = os.path.join(root_dir, filename) - file_path = os.path.abspath(file_path) - contents = """ - -invalid file format -""" - with open(file_path, 'w') as fhandle: - fhandle.write(contents) - with self.assertRaises(RuntimeError): - read_externals_description_file(root_dir, filename) - os.remove(file_path) - - -class TestCreateExternalsDescription(unittest.TestCase): - """Test the application logic of creat_externals_description - """ - - def setUp(self): - """Create config object used as basis for all tests - """ - self._config = config_parser() - self._gmconfig = config_parser() - self.setup_config() - - def setup_config(self): - """Boiler plate construction of xml string for componet 1 - """ - # Create a standard externals config with a single external - name = 'test' - self._config.add_section(name) - self._config.set(name, ExternalsDescription.PATH, 'externals') - self._config.set(name, ExternalsDescription.PROTOCOL, 'git') - self._config.set(name, ExternalsDescription.REPO_URL, '/path/to/repo') - self._config.set(name, ExternalsDescription.TAG, 'test_tag') - self._config.set(name, ExternalsDescription.REQUIRED, 'True') - - self._config.add_section(DESCRIPTION_SECTION) - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.0.0') - - # Create a .gitmodules test - name = 'submodule "gitmodules_test"' - self._gmconfig.add_section(name) - self._gmconfig.set(name, "path", 'externals/test') - self._gmconfig.set(name, "url", '/path/to/repo') - # NOTE(goldy, 2019-03) Should test other possible keywords such as - # fetchRecurseSubmodules, ignore, and shallow - - def test_cfg_v1_ok(self): - """Test that a correct cfg v1 object is created by create_externals_description - - """ - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.0.3') - ext = create_externals_description(self._config, model_format='cfg') - self.assertIsInstance(ext, ExternalsDescriptionConfigV1) - - def test_cfg_v1_unknown_version(self): - """Test that a config file with unknown schema version is rejected by - create_externals_description. - - """ - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, '100.0.3') - with self.assertRaises(RuntimeError): - create_externals_description(self._config, model_format='cfg') - - def test_dict(self): - """Test that a correct cfg v1 object is created by create_externals_description - - """ - rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: '/path/to/repo', - ExternalsDescription.TAG: 'tagv1', - } - - desc = { - 'test': { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: '../fake', - ExternalsDescription.EXTERNALS: EMPTY_STR, - ExternalsDescription.REPO: rdata, }, - } - - ext = create_externals_description(desc, model_format='dict') - self.assertIsInstance(ext, ExternalsDescriptionDict) - - def test_cfg_unknown_version(self): - """Test that a runtime error is raised when an unknown file version is - received - - """ - self._config.set(DESCRIPTION_SECTION, VERSION_ITEM, '123.456.789') - with self.assertRaises(RuntimeError): - create_externals_description(self._config, model_format='cfg') - - def test_cfg_unknown_format(self): - """Test that a runtime error is raised when an unknown format string is - received - - """ - with self.assertRaises(RuntimeError): - create_externals_description(self._config, model_format='unknown') - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_unit_externals_status.py b/manage_externals/test/test_unit_externals_status.py deleted file mode 100644 index f8e953f75..000000000 --- a/manage_externals/test/test_unit_externals_status.py +++ /dev/null @@ -1,299 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for the manic external status reporting module. - -Note: this script assumes the path to the manic package is already in -the python path. - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import unittest - -from manic.externals_status import ExternalStatus - - -class TestStatusObject(unittest.TestCase): - """Verify that the Status object behaives as expected. - """ - - def test_exists_empty_all(self): - """If the repository sync-state is empty (doesn't exist), and there is no - clean state, then it is considered not to exist. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.EMPTY - stat.clean_state = ExternalStatus.DEFAULT - exists = stat.exists() - self.assertFalse(exists) - - stat.clean_state = ExternalStatus.EMPTY - exists = stat.exists() - self.assertFalse(exists) - - stat.clean_state = ExternalStatus.UNKNOWN - exists = stat.exists() - self.assertFalse(exists) - - # this state represtens an internal logic error in how the - # repo status was determined. - stat.clean_state = ExternalStatus.STATUS_OK - exists = stat.exists() - self.assertTrue(exists) - - # this state represtens an internal logic error in how the - # repo status was determined. - stat.clean_state = ExternalStatus.DIRTY - exists = stat.exists() - self.assertTrue(exists) - - def test_exists_default_all(self): - """If the repository sync-state is default, then it is considered to exist - regardless of clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.DEFAULT - stat.clean_state = ExternalStatus.DEFAULT - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.EMPTY - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.UNKNOWN - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.STATUS_OK - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.DIRTY - exists = stat.exists() - self.assertTrue(exists) - - def test_exists_unknown_all(self): - """If the repository sync-state is unknown, then it is considered to exist - regardless of clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.UNKNOWN - stat.clean_state = ExternalStatus.DEFAULT - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.EMPTY - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.UNKNOWN - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.STATUS_OK - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.DIRTY - exists = stat.exists() - self.assertTrue(exists) - - def test_exists_modified_all(self): - """If the repository sync-state is modified, then it is considered to exist - regardless of clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.MODEL_MODIFIED - stat.clean_state = ExternalStatus.DEFAULT - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.EMPTY - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.UNKNOWN - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.STATUS_OK - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.DIRTY - exists = stat.exists() - self.assertTrue(exists) - - def test_exists_ok_all(self): - """If the repository sync-state is ok, then it is considered to exist - regardless of clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.STATUS_OK - stat.clean_state = ExternalStatus.DEFAULT - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.EMPTY - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.UNKNOWN - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.STATUS_OK - exists = stat.exists() - self.assertTrue(exists) - - stat.clean_state = ExternalStatus.DIRTY - exists = stat.exists() - self.assertTrue(exists) - - def test_update_ok_all(self): - """If the repository in-sync is ok, then it is safe to - update only if clean state is ok - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.STATUS_OK - stat.clean_state = ExternalStatus.DEFAULT - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.EMPTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.UNKNOWN - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.STATUS_OK - safe_to_update = stat.safe_to_update() - self.assertTrue(safe_to_update) - - stat.clean_state = ExternalStatus.DIRTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - def test_update_modified_all(self): - """If the repository in-sync is modified, then it is safe to - update only if clean state is ok - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.MODEL_MODIFIED - stat.clean_state = ExternalStatus.DEFAULT - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.EMPTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.UNKNOWN - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.STATUS_OK - safe_to_update = stat.safe_to_update() - self.assertTrue(safe_to_update) - - stat.clean_state = ExternalStatus.DIRTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - def test_update_unknown_all(self): - """If the repository in-sync is unknown, then it is not safe to - update, regardless of the clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.UNKNOWN - stat.clean_state = ExternalStatus.DEFAULT - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.EMPTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.UNKNOWN - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.STATUS_OK - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.DIRTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - def test_update_default_all(self): - """If the repository in-sync is default, then it is not safe to - update, regardless of the clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.UNKNOWN - stat.clean_state = ExternalStatus.DEFAULT - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.EMPTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.UNKNOWN - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.STATUS_OK - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.DIRTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - def test_update_empty_all(self): - """If the repository in-sync is empty, then it is not safe to - update, regardless of the clean state. - - """ - stat = ExternalStatus() - stat.sync_state = ExternalStatus.UNKNOWN - stat.clean_state = ExternalStatus.DEFAULT - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.EMPTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.UNKNOWN - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.STATUS_OK - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - stat.clean_state = ExternalStatus.DIRTY - safe_to_update = stat.safe_to_update() - self.assertFalse(safe_to_update) - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_unit_repository.py b/manage_externals/test/test_unit_repository.py deleted file mode 100644 index 2152503c2..000000000 --- a/manage_externals/test/test_unit_repository.py +++ /dev/null @@ -1,197 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for checkout_externals - -Note: this script assume the path to the checkout_externals.py module is -already in the python path. - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import unittest - -from manic.repository_factory import create_repository -from manic.repository_git import GitRepository -from manic.repository_svn import SvnRepository -from manic.repository import Repository -from manic.externals_description import ExternalsDescription -from manic.global_constants import EMPTY_STR - - -class TestCreateRepositoryDict(unittest.TestCase): - """Test the create_repository functionality to ensure it returns the - propper type of repository and errors for unknown repository - types. - - """ - - def setUp(self): - """Common data needed for all tests in this class - """ - self._name = 'test_name' - self._repo = {ExternalsDescription.PROTOCOL: None, - ExternalsDescription.REPO_URL: 'junk_root', - ExternalsDescription.TAG: 'junk_tag', - ExternalsDescription.BRANCH: EMPTY_STR, - ExternalsDescription.HASH: EMPTY_STR, } - - def test_create_repo_git(self): - """Verify that several possible names for the 'git' protocol - create git repository objects. - - """ - protocols = ['git', 'GIT', 'Git', ] - for protocol in protocols: - self._repo[ExternalsDescription.PROTOCOL] = protocol - repo = create_repository(self._name, self._repo) - self.assertIsInstance(repo, GitRepository) - - def test_create_repo_svn(self): - """Verify that several possible names for the 'svn' protocol - create svn repository objects. - """ - protocols = ['svn', 'SVN', 'Svn', ] - for protocol in protocols: - self._repo[ExternalsDescription.PROTOCOL] = protocol - repo = create_repository(self._name, self._repo) - self.assertIsInstance(repo, SvnRepository) - - def test_create_repo_externals_only(self): - """Verify that an externals only repo returns None. - """ - protocols = ['externals_only', ] - for protocol in protocols: - self._repo[ExternalsDescription.PROTOCOL] = protocol - repo = create_repository(self._name, self._repo) - self.assertEqual(None, repo) - - def test_create_repo_unsupported(self): - """Verify that an unsupported protocol generates a runtime error. - """ - protocols = ['not_a_supported_protocol', ] - for protocol in protocols: - self._repo[ExternalsDescription.PROTOCOL] = protocol - with self.assertRaises(RuntimeError): - create_repository(self._name, self._repo) - - -class TestRepository(unittest.TestCase): - """Test the externals description processing used to create the Repository - base class shared by protocol specific repository classes. - - """ - - def test_tag(self): - """Test creation of a repository object with a tag - """ - name = 'test_repo' - protocol = 'test_protocol' - url = 'test_url' - tag = 'test_tag' - repo_info = {ExternalsDescription.PROTOCOL: protocol, - ExternalsDescription.REPO_URL: url, - ExternalsDescription.TAG: tag, - ExternalsDescription.BRANCH: EMPTY_STR, - ExternalsDescription.HASH: EMPTY_STR, } - repo = Repository(name, repo_info) - print(repo.__dict__) - self.assertEqual(repo.tag(), tag) - self.assertEqual(repo.url(), url) - - def test_branch(self): - """Test creation of a repository object with a branch - """ - name = 'test_repo' - protocol = 'test_protocol' - url = 'test_url' - branch = 'test_branch' - repo_info = {ExternalsDescription.PROTOCOL: protocol, - ExternalsDescription.REPO_URL: url, - ExternalsDescription.BRANCH: branch, - ExternalsDescription.TAG: EMPTY_STR, - ExternalsDescription.HASH: EMPTY_STR, } - repo = Repository(name, repo_info) - print(repo.__dict__) - self.assertEqual(repo.branch(), branch) - self.assertEqual(repo.url(), url) - - def test_hash(self): - """Test creation of a repository object with a hash - """ - name = 'test_repo' - protocol = 'test_protocol' - url = 'test_url' - ref = 'deadc0de' - repo_info = {ExternalsDescription.PROTOCOL: protocol, - ExternalsDescription.REPO_URL: url, - ExternalsDescription.BRANCH: EMPTY_STR, - ExternalsDescription.TAG: EMPTY_STR, - ExternalsDescription.HASH: ref, } - repo = Repository(name, repo_info) - print(repo.__dict__) - self.assertEqual(repo.hash(), ref) - self.assertEqual(repo.url(), url) - - def test_tag_branch(self): - """Test creation of a repository object with a tag and branch raises a - runtimer error. - - """ - name = 'test_repo' - protocol = 'test_protocol' - url = 'test_url' - branch = 'test_branch' - tag = 'test_tag' - ref = EMPTY_STR - repo_info = {ExternalsDescription.PROTOCOL: protocol, - ExternalsDescription.REPO_URL: url, - ExternalsDescription.BRANCH: branch, - ExternalsDescription.TAG: tag, - ExternalsDescription.HASH: ref, } - with self.assertRaises(RuntimeError): - Repository(name, repo_info) - - def test_tag_branch_hash(self): - """Test creation of a repository object with a tag, branch and hash raises a - runtimer error. - - """ - name = 'test_repo' - protocol = 'test_protocol' - url = 'test_url' - branch = 'test_branch' - tag = 'test_tag' - ref = 'deadc0de' - repo_info = {ExternalsDescription.PROTOCOL: protocol, - ExternalsDescription.REPO_URL: url, - ExternalsDescription.BRANCH: branch, - ExternalsDescription.TAG: tag, - ExternalsDescription.HASH: ref, } - with self.assertRaises(RuntimeError): - Repository(name, repo_info) - - def test_no_tag_no_branch(self): - """Test creation of a repository object without a tag or branch raises a - runtimer error. - - """ - name = 'test_repo' - protocol = 'test_protocol' - url = 'test_url' - branch = EMPTY_STR - tag = EMPTY_STR - ref = EMPTY_STR - repo_info = {ExternalsDescription.PROTOCOL: protocol, - ExternalsDescription.REPO_URL: url, - ExternalsDescription.BRANCH: branch, - ExternalsDescription.TAG: tag, - ExternalsDescription.HASH: ref, } - with self.assertRaises(RuntimeError): - Repository(name, repo_info) - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_unit_repository_git.py b/manage_externals/test/test_unit_repository_git.py deleted file mode 100644 index b025fbd42..000000000 --- a/manage_externals/test/test_unit_repository_git.py +++ /dev/null @@ -1,807 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for checkout_externals - -Note: this script assume the path to the checkout_externals.py module is -already in the python path. - -""" -# pylint: disable=too-many-lines,protected-access - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import os -import shutil -import unittest - -from manic.repository_git import GitRepository -from manic.externals_status import ExternalStatus -from manic.externals_description import ExternalsDescription -from manic.externals_description import ExternalsDescriptionDict -from manic.global_constants import EMPTY_STR - -# NOTE(bja, 2017-11) order is important here. origin should be a -# subset of other to trap errors on processing remotes! -GIT_REMOTE_OUTPUT_ORIGIN_UPSTREAM = ''' -upstream /path/to/other/repo (fetch) -upstream /path/to/other/repo (push) -other /path/to/local/repo2 (fetch) -other /path/to/local/repo2 (push) -origin /path/to/local/repo (fetch) -origin /path/to/local/repo (push) -''' - - -class TestGitRepositoryCurrentRef(unittest.TestCase): - """test the current_ref command on a git repository - """ - - def setUp(self): - self._name = 'component' - rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: - '/path/to/local/repo', - ExternalsDescription.TAG: - 'tag1', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: 'junk', - ExternalsDescription.EXTERNALS: EMPTY_STR, - ExternalsDescription.REPO: rdata, - }, - } - - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = GitRepository('test', repo) - - # - # mock methods replacing git system calls - # - @staticmethod - def _git_current_branch(branch_found, branch_name): - """Return a function that takes the place of - repo._git_current_branch, which returns the given output.""" - def my_git_current_branch(): - """mock function that can take the place of repo._git_current_branch""" - return branch_found, branch_name - return my_git_current_branch - - @staticmethod - def _git_current_tag(tag_found, tag_name): - """Return a function that takes the place of - repo._git_current_tag, which returns the given output.""" - def my_git_current_tag(): - """mock function that can take the place of repo._git_current_tag""" - return tag_found, tag_name - return my_git_current_tag - - @staticmethod - def _git_current_hash(hash_found, hash_name): - """Return a function that takes the place of - repo._git_current_hash, which returns the given output.""" - def my_git_current_hash(): - """mock function that can take the place of repo._git_current_hash""" - return hash_found, hash_name - return my_git_current_hash - - # ------------------------------------------------------------------------ - # Begin tests - # ------------------------------------------------------------------------ - - def test_ref_branch(self): - """Test that we correctly identify we are on a branch - """ - self._repo._git_current_branch = self._git_current_branch( - True, 'feature3') - self._repo._git_current_tag = self._git_current_tag(True, 'foo_tag') - self._repo._git_current_hash = self._git_current_hash(True, 'abc123') - expected = 'feature3' - result = self._repo._current_ref() - self.assertEqual(result, expected) - - def test_ref_detached_tag(self): - """Test that we correctly identify that the ref is detached at a tag - """ - self._repo._git_current_branch = self._git_current_branch(False, '') - self._repo._git_current_tag = self._git_current_tag(True, 'foo_tag') - self._repo._git_current_hash = self._git_current_hash(True, 'abc123') - expected = 'foo_tag' - result = self._repo._current_ref() - self.assertEqual(result, expected) - - def test_ref_detached_hash(self): - """Test that we can identify ref is detached at a hash - - """ - self._repo._git_current_branch = self._git_current_branch(False, '') - self._repo._git_current_tag = self._git_current_tag(False, '') - self._repo._git_current_hash = self._git_current_hash(True, 'abc123') - expected = 'abc123' - result = self._repo._current_ref() - self.assertEqual(result, expected) - - def test_ref_none(self): - """Test that we correctly identify that we're not in a git repo. - """ - self._repo._git_current_branch = self._git_current_branch(False, '') - self._repo._git_current_tag = self._git_current_tag(False, '') - self._repo._git_current_hash = self._git_current_hash(False, '') - result = self._repo._current_ref() - self.assertEqual(result, EMPTY_STR) - - -class TestGitRepositoryCheckSync(unittest.TestCase): - """Test whether the GitRepository _check_sync_logic functionality is - correct. - - Note: there are a lot of combinations of state: - - - external description - tag, branch - - - working copy - - doesn't exist (not checked out) - - exists, no git info - incorrect protocol, e.g. svn, or tarball? - - exists, git info - - as expected: - - different from expected: - - detached tag, - - detached hash, - - detached branch (compare remote and branch), - - tracking branch (compare remote and branch), - - same remote - - different remote - - untracked branch - - Test list: - - doesn't exist - - exists no git info - - - num_external * (working copy expected + num_working copy different) - - total tests = 16 - - """ - - # NOTE(bja, 2017-11) pylint complains about long method names, but - # it is hard to differentiate tests without making them more - # cryptic. Also complains about too many public methods, but it - # doesn't really make sense to break this up. - # pylint: disable=invalid-name,too-many-public-methods - - TMP_FAKE_DIR = 'fake' - TMP_FAKE_GIT_DIR = os.path.join(TMP_FAKE_DIR, '.git') - - def setUp(self): - """Setup reusable git repository object - """ - self._name = 'component' - rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: - '/path/to/local/repo', - ExternalsDescription.TAG: 'tag1', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: self.TMP_FAKE_DIR, - ExternalsDescription.EXTERNALS: EMPTY_STR, - ExternalsDescription.REPO: rdata, - }, - } - - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = GitRepository('test', repo) - # The unit tests here don't care about the result of - # _current_ref, but we replace it here so that we don't need to - # worry about calling a possibly slow and possibly - # error-producing command (since _current_ref calls various git - # functions): - self._repo._current_ref = self._current_ref_empty - self._create_tmp_git_dir() - - def tearDown(self): - """Cleanup tmp stuff on the file system - """ - self._remove_tmp_git_dir() - - def _create_tmp_git_dir(self): - """Create a temporary fake git directory for testing purposes. - """ - if not os.path.exists(self.TMP_FAKE_GIT_DIR): - os.makedirs(self.TMP_FAKE_GIT_DIR) - - def _remove_tmp_git_dir(self): - """Remove the temporary fake git directory - """ - if os.path.exists(self.TMP_FAKE_DIR): - shutil.rmtree(self.TMP_FAKE_DIR) - - # - # mock methods replacing git system calls - # - @staticmethod - def _current_ref_empty(): - """Return an empty string. - """ - return EMPTY_STR - - @staticmethod - def _git_remote_origin_upstream(): - """Return an info string that is a checkout hash - """ - return GIT_REMOTE_OUTPUT_ORIGIN_UPSTREAM - - @staticmethod - def _git_remote_none(): - """Return an info string that is a checkout hash - """ - return EMPTY_STR - - @staticmethod - def _git_current_hash(myhash): - """Return a function that takes the place of repo._git_current_hash, - which returns the given hash - """ - def my_git_current_hash(): - """mock function that can take the place of repo._git_current_hash""" - return 0, myhash - return my_git_current_hash - - def _git_revparse_commit(self, expected_ref, mystatus, myhash): - """Return a function that takes the place of - repo._git_revparse_commit, which returns a tuple: - (mystatus, myhash). - - Expects the passed-in ref to equal expected_ref - - status = 0 implies success, non-zero implies failure - """ - def my_git_revparse_commit(ref): - """mock function that can take the place of repo._git_revparse_commit""" - self.assertEqual(expected_ref, ref) - return mystatus, myhash - return my_git_revparse_commit - - # ---------------------------------------------------------------- - # - # Tests where working copy doesn't exist or is invalid - # - # ---------------------------------------------------------------- - def test_sync_dir_not_exist(self): - """Test that a directory that doesn't exist returns an error status - - Note: the Repository classes should be prevented from ever - working on an empty directory by the _Source object. - - """ - stat = ExternalStatus() - self._repo._check_sync(stat, 'invalid_directory_name') - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_ERROR) - # check_dir should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_sync_dir_exist_no_git_info(self): - """Test that a non-existent git repo returns an unknown status - """ - stat = ExternalStatus() - # Now we over-ride the _git_remote_verbose method on the repo to return - # a known value without requiring access to git. - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._tag = 'tag1' - self._repo._git_current_hash = self._git_current_hash('') - self._repo._git_revparse_commit = self._git_revparse_commit( - 'tag1', 1, '') - self._repo._check_sync(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.UNKNOWN) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - # ------------------------------------------------------------------------ - # - # Tests where version in configuration file is not a valid reference - # - # ------------------------------------------------------------------------ - - def test_sync_invalid_reference(self): - """Test that an invalid reference returns out-of-sync - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._tag = 'tag1' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = self._git_revparse_commit( - 'tag1', 1, '') - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.MODEL_MODIFIED) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - # ---------------------------------------------------------------- - # - # Tests where external description specifies a tag - # - # ---------------------------------------------------------------- - def test_sync_tag_on_same_hash(self): - """Test expect tag on same hash --> status ok - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._tag = 'tag1' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = self._git_revparse_commit( - 'tag1', 0, 'abc123') - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_OK) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_sync_tag_on_different_hash(self): - """Test expect tag on a different hash --> status modified - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._tag = 'tag1' - self._repo._git_current_hash = self._git_current_hash('def456') - self._repo._git_revparse_commit = self._git_revparse_commit( - 'tag1', 0, 'abc123') - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.MODEL_MODIFIED) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - # ---------------------------------------------------------------- - # - # Tests where external description specifies a hash - # - # ---------------------------------------------------------------- - def test_sync_hash_on_same_hash(self): - """Test expect hash on same hash --> status ok - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._tag = '' - self._repo._hash = 'abc' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = self._git_revparse_commit( - 'abc', 0, 'abc123') - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_OK) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_sync_hash_on_different_hash(self): - """Test expect hash on a different hash --> status modified - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._tag = '' - self._repo._hash = 'abc' - self._repo._git_current_hash = self._git_current_hash('def456') - self._repo._git_revparse_commit = self._git_revparse_commit( - 'abc', 0, 'abc123') - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.MODEL_MODIFIED) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - # ---------------------------------------------------------------- - # - # Tests where external description specifies a branch - # - # ---------------------------------------------------------------- - def test_sync_branch_on_same_hash(self): - """Test expect branch on same hash --> status ok - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._branch = 'feature-2' - self._repo._tag = '' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = ( - self._git_revparse_commit('origin/feature-2', 0, 'abc123')) - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_OK) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_sync_branch_on_diff_hash(self): - """Test expect branch on diff hash --> status modified - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._branch = 'feature-2' - self._repo._tag = '' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = ( - self._git_revparse_commit('origin/feature-2', 0, 'def456')) - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.MODEL_MODIFIED) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_sync_branch_diff_remote(self): - """Test _determine_remote_name with a different remote - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._branch = 'feature-2' - self._repo._tag = '' - self._repo._url = '/path/to/other/repo' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = ( - self._git_revparse_commit('upstream/feature-2', 0, 'def456')) - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - # The test passes if _git_revparse_commit is called with the - # expected argument - - def test_sync_branch_diff_remote2(self): - """Test _determine_remote_name with a different remote - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._branch = 'feature-2' - self._repo._tag = '' - self._repo._url = '/path/to/local/repo2' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = ( - self._git_revparse_commit('other/feature-2', 0, 'def789')) - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - # The test passes if _git_revparse_commit is called with the - # expected argument - - def test_sync_branch_on_unknown_remote(self): - """Test expect branch, but remote is unknown --> status modified - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._branch = 'feature-2' - self._repo._tag = '' - self._repo._url = '/path/to/unknown/repo' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = ( - self._git_revparse_commit('unknown_remote/feature-2', 1, '')) - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.MODEL_MODIFIED) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_sync_branch_on_untracked_local(self): - """Test expect branch, on untracked branch in local repo --> status ok - - Setting the externals description to '.' indicates that the - user only wants to consider the current local repo state - without fetching from remotes. This is required to preserve - the current branch of a repository during an update. - - """ - stat = ExternalStatus() - self._repo._git_remote_verbose = self._git_remote_origin_upstream - self._repo._branch = 'feature3' - self._repo._tag = '' - self._repo._url = '.' - self._repo._git_current_hash = self._git_current_hash('abc123') - self._repo._git_revparse_commit = ( - self._git_revparse_commit('feature3', 0, 'abc123')) - self._repo._check_sync_logic(stat, self.TMP_FAKE_DIR) - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_OK) - # check_sync should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - -class TestGitStatusPorcelain(unittest.TestCase): - """Test parsing of output from git status --porcelain=v1 -z - """ - # pylint: disable=C0103 - GIT_STATUS_PORCELAIN_V1_ALL = ( - r' D INSTALL\0MM Makefile\0M README.md\0R cmakelists.txt\0' - r'CMakeLists.txt\0D commit-message-template.txt\0A stuff.txt\0' - r'?? junk.txt') - - GIT_STATUS_PORCELAIN_CLEAN = r'' - - def test_porcelain_status_dirty(self): - """Verify that git status output is considered dirty when there are - listed files. - - """ - git_output = self.GIT_STATUS_PORCELAIN_V1_ALL - is_dirty = GitRepository._status_v1z_is_dirty(git_output) - self.assertTrue(is_dirty) - - def test_porcelain_status_clean(self): - """Verify that git status output is considered clean when there are no - listed files. - - """ - git_output = self.GIT_STATUS_PORCELAIN_CLEAN - is_dirty = GitRepository._status_v1z_is_dirty(git_output) - self.assertFalse(is_dirty) - - -class TestGitCreateRemoteName(unittest.TestCase): - """Test the create_remote_name method on the GitRepository class - """ - - def setUp(self): - """Common infrastructure for testing _create_remote_name - """ - self._rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: - 'empty', - ExternalsDescription.TAG: - 'very_useful_tag', - ExternalsDescription.BRANCH: EMPTY_STR, - ExternalsDescription.HASH: EMPTY_STR, } - self._repo = GitRepository('test', self._rdata) - - def test_remote_git_proto(self): - """Test remote with git protocol - """ - self._repo._url = 'git@git.github.com:very_nice_org/useful_repo' - remote_name = self._repo._create_remote_name() - self.assertEqual(remote_name, 'very_nice_org_useful_repo') - - def test_remote_https_proto(self): - """Test remote with git protocol - """ - self._repo._url = 'https://www.github.com/very_nice_org/useful_repo' - remote_name = self._repo._create_remote_name() - self.assertEqual(remote_name, 'very_nice_org_useful_repo') - - def test_remote_local_abs(self): - """Test remote with git protocol - """ - self._repo._url = '/path/to/local/repositories/useful_repo' - remote_name = self._repo._create_remote_name() - self.assertEqual(remote_name, 'repositories_useful_repo') - - def test_remote_local_rel(self): - """Test remote with git protocol - """ - os.environ['TEST_VAR'] = '/my/path/to/repos' - self._repo._url = '${TEST_VAR}/../../useful_repo' - remote_name = self._repo._create_remote_name() - self.assertEqual(remote_name, 'path_useful_repo') - del os.environ['TEST_VAR'] - - -class TestVerifyTag(unittest.TestCase): - """Test logic verifying that a tag exists and is unique - - """ - - def setUp(self): - """Setup reusable git repository object - """ - self._name = 'component' - rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: - '/path/to/local/repo', - ExternalsDescription.TAG: 'tag1', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: 'tmp', - ExternalsDescription.EXTERNALS: EMPTY_STR, - ExternalsDescription.REPO: rdata, - }, - } - - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = GitRepository('test', repo) - - @staticmethod - def _shell_true(url, remote=None): - _ = url - _ = remote - return 0 - - @staticmethod - def _shell_false(url, remote=None): - _ = url - _ = remote - return 1 - - @staticmethod - def _mock_function_true(ref): - _ = ref - return (TestValidRef._shell_true, '97ebc0e0deadc0de') - - @staticmethod - def _mock_function_false(ref): - _ = ref - return (TestValidRef._shell_false, '97ebc0e0deadc0de') - - def test_tag_not_tag_branch_commit(self): - """Verify a non-tag returns false - """ - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_false - self._repo._tag = 'something' - remote_name = 'origin' - received, _ = self._repo._is_unique_tag(self._repo._tag, remote_name) - self.assertFalse(received) - - def test_tag_not_tag(self): - """Verify a non-tag, untracked remote returns false - """ - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_true - self._repo._git_lsremote_branch = self._shell_true - self._repo._git_revparse_commit = self._mock_function_false - self._repo._tag = 'tag1' - remote_name = 'origin' - received, _ = self._repo._is_unique_tag(self._repo._tag, remote_name) - self.assertFalse(received) - - def test_tag_indeterminant(self): - """Verify an indeterminant tag/branch returns false - """ - self._repo._git_showref_tag = self._shell_true - self._repo._git_showref_branch = self._shell_true - self._repo._git_lsremote_branch = self._shell_true - self._repo._git_revparse_commit = self._mock_function_true - self._repo._tag = 'something' - remote_name = 'origin' - received, _ = self._repo._is_unique_tag(self._repo._tag, remote_name) - self.assertFalse(received) - - def test_tag_is_unique(self): - """Verify a unique tag match returns true - """ - self._repo._git_showref_tag = self._shell_true - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_true - self._repo._tag = 'tag1' - remote_name = 'origin' - received, _ = self._repo._is_unique_tag(self._repo._tag, remote_name) - self.assertTrue(received) - - def test_tag_is_not_hash(self): - """Verify a commit hash is not classified as a tag - """ - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_true - self._repo._tag = '97ebc0e0' - remote_name = 'origin' - received, _ = self._repo._is_unique_tag(self._repo._tag, remote_name) - self.assertFalse(received) - - def test_hash_is_commit(self): - """Verify a commit hash is not classified as a tag - """ - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_true - self._repo._tag = '97ebc0e0' - remote_name = 'origin' - received, _ = self._repo._is_unique_tag(self._repo._tag, remote_name) - self.assertFalse(received) - - -class TestValidRef(unittest.TestCase): - """Test logic verifying that a reference is a valid tag, branch or sha1 - - """ - - def setUp(self): - """Setup reusable git repository object - """ - self._name = 'component' - rdata = {ExternalsDescription.PROTOCOL: 'git', - ExternalsDescription.REPO_URL: - '/path/to/local/repo', - ExternalsDescription.TAG: 'tag1', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: 'tmp', - ExternalsDescription.EXTERNALS: EMPTY_STR, - ExternalsDescription.REPO: rdata, - }, - } - - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = GitRepository('test', repo) - - @staticmethod - def _shell_true(url, remote=None): - _ = url - _ = remote - return 0 - - @staticmethod - def _shell_false(url, remote=None): - _ = url - _ = remote - return 1 - - @staticmethod - def _mock_function_false(ref): - _ = ref - return (TestValidRef._shell_false, '') - - @staticmethod - def _mock_function_true(ref): - _ = ref - return (TestValidRef._shell_true, '') - - def test_valid_ref_is_invalid(self): - """Verify an invalid reference raises an exception - """ - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_false - self._repo._tag = 'invalid_ref' - with self.assertRaises(RuntimeError): - self._repo._check_for_valid_ref(self._repo._tag) - - def test_valid_tag(self): - """Verify a valid tag return true - """ - self._repo._git_showref_tag = self._shell_true - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_true - self._repo._tag = 'tag1' - received = self._repo._check_for_valid_ref(self._repo._tag) - self.assertTrue(received) - - def test_valid_branch(self): - """Verify a valid tag return true - """ - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_true - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = self._mock_function_true - self._repo._tag = 'tag1' - received = self._repo._check_for_valid_ref(self._repo._tag) - self.assertTrue(received) - - def test_valid_hash(self): - """Verify a valid hash return true - """ - def _mock_revparse_commit(ref): - _ = ref - return (0, '56cc0b539426eb26810af9e') - - self._repo._git_showref_tag = self._shell_false - self._repo._git_showref_branch = self._shell_false - self._repo._git_lsremote_branch = self._shell_false - self._repo._git_revparse_commit = _mock_revparse_commit - self._repo._hash = '56cc0b5394' - received = self._repo._check_for_valid_ref(self._repo._hash) - self.assertTrue(received) - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_unit_repository_svn.py b/manage_externals/test/test_unit_repository_svn.py deleted file mode 100644 index 7ff31c421..000000000 --- a/manage_externals/test/test_unit_repository_svn.py +++ /dev/null @@ -1,501 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for checkout_externals - -Note: this script assume the path to the checkout_externals.py module is -already in the python path. - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import unittest - -from manic.repository_svn import SvnRepository -from manic.externals_status import ExternalStatus -from manic.externals_description import ExternalsDescription -from manic.externals_description import ExternalsDescriptionDict -from manic.global_constants import EMPTY_STR - -# pylint: disable=W0212 - -SVN_INFO_MOSART = """Path: components/mosart -Working Copy Root Path: /Users/andreb/projects/ncar/git-conversion/clm-dev-experimental/components/mosart -URL: https://svn-ccsm-models.cgd.ucar.edu/mosart/trunk_tags/mosart1_0_26 -Relative URL: ^/mosart/trunk_tags/mosart1_0_26 -Repository Root: https://svn-ccsm-models.cgd.ucar.edu -Repository UUID: fe37f545-8307-0410-aea5-b40df96820b5 -Revision: 86711 -Node Kind: directory -Schedule: normal -Last Changed Author: erik -Last Changed Rev: 86031 -Last Changed Date: 2017-07-07 12:28:10 -0600 (Fri, 07 Jul 2017) -""" -SVN_INFO_CISM = """ -Path: components/cism -Working Copy Root Path: /Users/andreb/projects/ncar/git-conversion/clm-dev-experimental/components/cism -URL: https://svn-ccsm-models.cgd.ucar.edu/glc/trunk_tags/cism2_1_37 -Relative URL: ^/glc/trunk_tags/cism2_1_37 -Repository Root: https://svn-ccsm-models.cgd.ucar.edu -Repository UUID: fe37f545-8307-0410-aea5-b40df96820b5 -Revision: 86711 -Node Kind: directory -Schedule: normal -Last Changed Author: sacks -Last Changed Rev: 85704 -Last Changed Date: 2017-06-15 05:59:28 -0600 (Thu, 15 Jun 2017) -""" - - -class TestSvnRepositoryCheckURL(unittest.TestCase): - """Verify that the svn_check_url function is working as expected. - """ - - def setUp(self): - """Setup reusable svn repository object - """ - self._name = 'component' - rdata = {ExternalsDescription.PROTOCOL: 'svn', - ExternalsDescription.REPO_URL: - 'https://svn-ccsm-models.cgd.ucar.edu/', - ExternalsDescription.TAG: - 'mosart/trunk_tags/mosart1_0_26', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: 'junk', - ExternalsDescription.EXTERNALS: '', - ExternalsDescription.REPO: rdata, - }, - } - - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = SvnRepository('test', repo) - - def test_check_url_same(self): - """Test that we correctly identify that the correct URL. - """ - svn_output = SVN_INFO_MOSART - expected_url = self._repo.url() - result, current_version = \ - self._repo._check_url(svn_output, expected_url) - self.assertEqual(result, ExternalStatus.STATUS_OK) - self.assertEqual(current_version, 'mosart/trunk_tags/mosart1_0_26') - - def test_check_url_different(self): - """Test that we correctly reject an incorrect URL. - """ - svn_output = SVN_INFO_CISM - expected_url = self._repo.url() - result, current_version = \ - self._repo._check_url(svn_output, expected_url) - self.assertEqual(result, ExternalStatus.MODEL_MODIFIED) - self.assertEqual(current_version, 'glc/trunk_tags/cism2_1_37') - - def test_check_url_none(self): - """Test that we can handle an empty string for output, e.g. not an svn - repo. - - """ - svn_output = EMPTY_STR - expected_url = self._repo.url() - result, current_version = \ - self._repo._check_url(svn_output, expected_url) - self.assertEqual(result, ExternalStatus.UNKNOWN) - self.assertEqual(current_version, '') - - -class TestSvnRepositoryCheckSync(unittest.TestCase): - """Test whether the SvnRepository svn_check_sync functionality is - correct. - - """ - - def setUp(self): - """Setup reusable svn repository object - """ - self._name = "component" - rdata = {ExternalsDescription.PROTOCOL: 'svn', - ExternalsDescription.REPO_URL: - 'https://svn-ccsm-models.cgd.ucar.edu/', - ExternalsDescription.TAG: - 'mosart/trunk_tags/mosart1_0_26', - } - - data = {self._name: - { - ExternalsDescription.REQUIRED: False, - ExternalsDescription.PATH: 'junk', - ExternalsDescription.EXTERNALS: EMPTY_STR, - ExternalsDescription.REPO: rdata, - }, - } - - model = ExternalsDescriptionDict(data) - repo = model[self._name][ExternalsDescription.REPO] - self._repo = SvnRepository('test', repo) - - @staticmethod - def _svn_info_empty(*_): - """Return an empty info string. Simulates svn info failing. - """ - return '' - - @staticmethod - def _svn_info_synced(*_): - """Return an info sting that is synced with the setUp data - """ - return SVN_INFO_MOSART - - @staticmethod - def _svn_info_modified(*_): - """Return and info string that is modified from the setUp data - """ - return SVN_INFO_CISM - - def test_repo_dir_not_exist(self): - """Test that a directory that doesn't exist returns an error status - - Note: the Repository classes should be prevented from ever - working on an empty directory by the _Source object. - - """ - stat = ExternalStatus() - self._repo._check_sync(stat, 'junk') - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_ERROR) - # check_dir should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_repo_dir_exist_no_svn_info(self): - """Test that an empty info string returns an unknown status - """ - stat = ExternalStatus() - # Now we over-ride the _svn_info method on the repo to return - # a known value without requiring access to svn. - self._repo._svn_info = self._svn_info_empty - self._repo._check_sync(stat, '.') - self.assertEqual(stat.sync_state, ExternalStatus.UNKNOWN) - # check_dir should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_repo_dir_synced(self): - """Test that a valid info string that is synced to the repo in the - externals description returns an ok status. - - """ - stat = ExternalStatus() - # Now we over-ride the _svn_info method on the repo to return - # a known value without requiring access to svn. - self._repo._svn_info = self._svn_info_synced - self._repo._check_sync(stat, '.') - self.assertEqual(stat.sync_state, ExternalStatus.STATUS_OK) - # check_dir should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - def test_repo_dir_modified(self): - """Test that a valid svn info string that is out of sync with the - externals description returns a modified status. - - """ - stat = ExternalStatus() - # Now we over-ride the _svn_info method on the repo to return - # a known value without requiring access to svn. - self._repo._svn_info = self._svn_info_modified - self._repo._check_sync(stat, '.') - self.assertEqual(stat.sync_state, ExternalStatus.MODEL_MODIFIED) - # check_dir should only modify the sync_state, not clean_state - self.assertEqual(stat.clean_state, ExternalStatus.DEFAULT) - - -class TestSVNStatusXML(unittest.TestCase): - """Test parsing of svn status xml output - """ - SVN_STATUS_XML_DIRTY_ALL = ''' - - - - - -sacks -2017-06-15T11:59:00.355419Z - - - - - - -sacks -2013-02-07T16:17:56.412878Z - - - - - - -sacks -2017-05-01T16:48:27.893741Z - - - - - - - - - - - - - - - - -''' - - SVN_STATUS_XML_DIRTY_MISSING = ''' - - - - - -sacks -2017-06-15T11:59:00.355419Z - - - - - - - - -''' - - SVN_STATUS_XML_DIRTY_MODIFIED = ''' - - - - - -sacks -2013-02-07T16:17:56.412878Z - - - - - - - - -''' - - SVN_STATUS_XML_DIRTY_DELETED = ''' - - - - - -sacks -2017-05-01T16:48:27.893741Z - - - - - - - - -''' - - SVN_STATUS_XML_DIRTY_UNVERSION = ''' - - - - - - - - - - - -''' - - SVN_STATUS_XML_DIRTY_ADDED = ''' - - - - - - - - - - - -''' - - SVN_STATUS_XML_CLEAN = ''' - - - - - - - - - - - -''' - - def test_xml_status_dirty_missing(self): - """Verify that svn status output is consindered dirty when there is a - missing file. - - """ - svn_output = self.SVN_STATUS_XML_DIRTY_MISSING - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertTrue(is_dirty) - - def test_xml_status_dirty_modified(self): - """Verify that svn status output is consindered dirty when there is a - modified file. - """ - svn_output = self.SVN_STATUS_XML_DIRTY_MODIFIED - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertTrue(is_dirty) - - def test_xml_status_dirty_deleted(self): - """Verify that svn status output is consindered dirty when there is a - deleted file. - """ - svn_output = self.SVN_STATUS_XML_DIRTY_DELETED - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertTrue(is_dirty) - - def test_xml_status_dirty_unversion(self): - """Verify that svn status output ignores unversioned files when making - the clean/dirty decision. - - """ - svn_output = self.SVN_STATUS_XML_DIRTY_UNVERSION - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertFalse(is_dirty) - - def test_xml_status_dirty_added(self): - """Verify that svn status output is consindered dirty when there is a - added file. - """ - svn_output = self.SVN_STATUS_XML_DIRTY_ADDED - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertTrue(is_dirty) - - def test_xml_status_dirty_all(self): - """Verify that svn status output is consindered dirty when there are - multiple dirty files.. - - """ - svn_output = self.SVN_STATUS_XML_DIRTY_ALL - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertTrue(is_dirty) - - def test_xml_status_dirty_clean(self): - """Verify that svn status output is consindered clean when there are - no 'dirty' files. This means accepting untracked and externals. - - """ - svn_output = self.SVN_STATUS_XML_CLEAN - is_dirty = SvnRepository.xml_status_is_dirty( - svn_output) - self.assertFalse(is_dirty) - - -if __name__ == '__main__': - unittest.main() diff --git a/manage_externals/test/test_unit_utils.py b/manage_externals/test/test_unit_utils.py deleted file mode 100644 index c994e58eb..000000000 --- a/manage_externals/test/test_unit_utils.py +++ /dev/null @@ -1,350 +0,0 @@ -#!/usr/bin/env python - -"""Unit test driver for checkout_externals - -Note: this script assume the path to the checkout_externals.py module is -already in the python path. - -""" - -from __future__ import absolute_import -from __future__ import unicode_literals -from __future__ import print_function - -import os -import unittest - -from manic.utils import last_n_lines, indent_string -from manic.utils import str_to_bool, execute_subprocess -from manic.utils import is_remote_url, split_remote_url, expand_local_url - - -class TestExecuteSubprocess(unittest.TestCase): - """Test the application logic of execute_subprocess wrapper - """ - - def test_exesub_return_stat_err(self): - """Test that execute_subprocess returns a status code when caller - requests and the executed subprocess fails. - - """ - cmd = ['false'] - status = execute_subprocess(cmd, status_to_caller=True) - self.assertEqual(status, 1) - - def test_exesub_return_stat_ok(self): - """Test that execute_subprocess returns a status code when caller - requests and the executed subprocess succeeds. - - """ - cmd = ['true'] - status = execute_subprocess(cmd, status_to_caller=True) - self.assertEqual(status, 0) - - def test_exesub_except_stat_err(self): - """Test that execute_subprocess raises an exception on error when - caller doesn't request return code - - """ - cmd = ['false'] - with self.assertRaises(RuntimeError): - execute_subprocess(cmd, status_to_caller=False) - - -class TestLastNLines(unittest.TestCase): - """Test the last_n_lines function. - - """ - - def test_last_n_lines_short(self): - """With a message with <= n lines, result of last_n_lines should - just be the original message. - - """ - mystr = """three -line -string -""" - - mystr_truncated = last_n_lines( - mystr, 3, truncation_message='[truncated]') - self.assertEqual(mystr, mystr_truncated) - - def test_last_n_lines_long(self): - """With a message with > n lines, result of last_n_lines should - be a truncated string. - - """ - mystr = """a -big -five -line -string -""" - expected = """[truncated] -five -line -string -""" - - mystr_truncated = last_n_lines( - mystr, 3, truncation_message='[truncated]') - self.assertEqual(expected, mystr_truncated) - - -class TestIndentStr(unittest.TestCase): - """Test the indent_string function. - - """ - - def test_indent_string_singleline(self): - """Test the indent_string function with a single-line string - - """ - mystr = 'foo' - result = indent_string(mystr, 4) - expected = ' foo' - self.assertEqual(expected, result) - - def test_indent_string_multiline(self): - """Test the indent_string function with a multi-line string - - """ - mystr = """hello -hi -goodbye -""" - result = indent_string(mystr, 2) - expected = """ hello - hi - goodbye -""" - self.assertEqual(expected, result) - - -class TestStrToBool(unittest.TestCase): - """Test the string to boolean conversion routine. - - """ - - def test_case_insensitive_true(self): - """Verify that case insensitive variants of 'true' returns the True - boolean. - - """ - values = ['true', 'TRUE', 'True', 'tRuE', 't', 'T', ] - for value in values: - received = str_to_bool(value) - self.assertTrue(received) - - def test_case_insensitive_false(self): - """Verify that case insensitive variants of 'false' returns the False - boolean. - - """ - values = ['false', 'FALSE', 'False', 'fAlSe', 'f', 'F', ] - for value in values: - received = str_to_bool(value) - self.assertFalse(received) - - def test_invalid_str_error(self): - """Verify that a non-true/false string generates a runtime error. - """ - values = ['not_true_or_false', 'A', '1', '0', - 'false_is_not_true', 'true_is_not_false'] - for value in values: - with self.assertRaises(RuntimeError): - str_to_bool(value) - - -class TestIsRemoteURL(unittest.TestCase): - """Crude url checking to determine if a url is local or remote. - - """ - - def test_url_remote_git(self): - """verify that a remote git url is identified. - """ - url = 'git@somewhere' - is_remote = is_remote_url(url) - self.assertTrue(is_remote) - - def test_url_remote_ssh(self): - """verify that a remote ssh url is identified. - """ - url = 'ssh://user@somewhere' - is_remote = is_remote_url(url) - self.assertTrue(is_remote) - - def test_url_remote_http(self): - """verify that a remote http url is identified. - """ - url = 'http://somewhere' - is_remote = is_remote_url(url) - self.assertTrue(is_remote) - - def test_url_remote_https(self): - """verify that a remote https url is identified. - """ - url = 'https://somewhere' - is_remote = is_remote_url(url) - self.assertTrue(is_remote) - - def test_url_local_user(self): - """verify that a local path with '~/path/to/repo' gets rejected - - """ - url = '~/path/to/repo' - is_remote = is_remote_url(url) - self.assertFalse(is_remote) - - def test_url_local_var_curly(self): - """verify that a local path with env var '${HOME}' gets rejected - """ - url = '${HOME}/path/to/repo' - is_remote = is_remote_url(url) - self.assertFalse(is_remote) - - def test_url_local_var(self): - """verify that a local path with an env var '$HOME' gets rejected - """ - url = '$HOME/path/to/repo' - is_remote = is_remote_url(url) - self.assertFalse(is_remote) - - def test_url_local_abs(self): - """verify that a local abs path gets rejected - """ - url = '/path/to/repo' - is_remote = is_remote_url(url) - self.assertFalse(is_remote) - - def test_url_local_rel(self): - """verify that a local relative path gets rejected - """ - url = '../../path/to/repo' - is_remote = is_remote_url(url) - self.assertFalse(is_remote) - - -class TestSplitRemoteURL(unittest.TestCase): - """Crude url checking to determine if a url is local or remote. - - """ - - def test_url_remote_git(self): - """verify that a remote git url is identified. - """ - url = 'git@somewhere.com:org/repo' - received = split_remote_url(url) - self.assertEqual(received, "org/repo") - - def test_url_remote_ssh(self): - """verify that a remote ssh url is identified. - """ - url = 'ssh://user@somewhere.com/path/to/repo' - received = split_remote_url(url) - self.assertEqual(received, 'somewhere.com/path/to/repo') - - def test_url_remote_http(self): - """verify that a remote http url is identified. - """ - url = 'http://somewhere.org/path/to/repo' - received = split_remote_url(url) - self.assertEqual(received, 'somewhere.org/path/to/repo') - - def test_url_remote_https(self): - """verify that a remote http url is identified. - """ - url = 'http://somewhere.gov/path/to/repo' - received = split_remote_url(url) - self.assertEqual(received, 'somewhere.gov/path/to/repo') - - def test_url_local_url_unchanged(self): - """verify that a local path is unchanged - - """ - url = '/path/to/repo' - received = split_remote_url(url) - self.assertEqual(received, url) - - -class TestExpandLocalURL(unittest.TestCase): - """Crude url checking to determine if a url is local or remote. - - Remote should be unmodified. - - Local, should perform user and variable expansion. - - """ - - def test_url_local_user1(self): - """verify that a local path with '~/path/to/repo' gets expanded to an - absolute path. - - NOTE(bja, 2017-11) we can't test for something like: - '~user/path/to/repo' because the user has to be in the local - machine password directory and we don't know a user name that - is valid on every system....? - - """ - field = 'test' - url = '~/path/to/repo' - received = expand_local_url(url, field) - print(received) - self.assertTrue(os.path.isabs(received)) - - def test_url_local_expand_curly(self): - """verify that a local path with '${HOME}' gets expanded to an absolute path. - """ - field = 'test' - url = '${HOME}/path/to/repo' - received = expand_local_url(url, field) - self.assertTrue(os.path.isabs(received)) - - def test_url_local_expand_var(self): - """verify that a local path with '$HOME' gets expanded to an absolute path. - """ - field = 'test' - url = '$HOME/path/to/repo' - received = expand_local_url(url, field) - self.assertTrue(os.path.isabs(received)) - - def test_url_local_env_missing(self): - """verify that a local path with env var that is missing gets left as-is - - """ - field = 'test' - url = '$TMP_VAR/path/to/repo' - received = expand_local_url(url, field) - print(received) - self.assertEqual(received, url) - - def test_url_local_expand_env(self): - """verify that a local path with another env var gets expanded to an - absolute path. - - """ - field = 'test' - os.environ['TMP_VAR'] = '/some/absolute' - url = '$TMP_VAR/path/to/repo' - received = expand_local_url(url, field) - del os.environ['TMP_VAR'] - print(received) - self.assertTrue(os.path.isabs(received)) - self.assertEqual(received, '/some/absolute/path/to/repo') - - def test_url_local_normalize_rel(self): - """verify that a local path with another env var gets expanded to an - absolute path. - - """ - field = 'test' - url = '/this/is/a/long/../path/to/a/repo' - received = expand_local_url(url, field) - print(received) - self.assertEqual(received, '/this/is/a/path/to/a/repo') - - -if __name__ == '__main__': - unittest.main() diff --git a/modulefiles/cheyenne b/modulefiles/cheyenne new file mode 100644 index 000000000..f5a40a5bd --- /dev/null +++ b/modulefiles/cheyenne @@ -0,0 +1,39 @@ +#%Module# + +proc ModulesHelp { } { +puts stderr "Loads modules required for building upp" +} +module-whatis "Loads UPP prerequisites on Cheyenne for Intel 2021.2" + +module purge + +module load cmake/3.18.2 +module load ncarenv/1.3 +module load intel/2021.2 +module load mpt/2.22 +module load ncarcompilers/0.5.0 +module unload netcdf + +module use /glade/p/ral/jntp/GMTB/tools/hpc-stack-v1.2.0/modulefiles/stack +module load hpc/1.2.0 +module load hpc-intel/2021.2 +module load hpc-mpt/2.22 + +module load jasper/2.0.25 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 + +module load bacio/2.4.1 +module load crtm/2.3.0 +module load g2/3.4.2 +module load g2tmpl/1.10.0 +module load ip/3.3.3 +module load nemsio/2.5.2 +module load sfcio/1.4.1 +module load sigio/2.3.2 +module load sp/2.3.3 +module load w3emc/2.9.2 +module load wrf_io/1.2.0 diff --git a/modulefiles/cheyenne_gnu b/modulefiles/cheyenne_gnu new file mode 100644 index 000000000..d14c372e6 --- /dev/null +++ b/modulefiles/cheyenne_gnu @@ -0,0 +1,40 @@ +#%Module# + +proc ModulesHelp { } { +puts stderr "Loads modules required for building upp" +} +module-whatis "Loads UPP prerequisites on Cheyenne for Intel 2021.2" + +module purge + +module load cmake/3.18.2 +module load ncarenv/1.3 +module load gnu/10.1.0 +module load mpt/2.22 +module load ncarcompilers/0.5.0 +module load python/3.7.9 +module unload netcdf + +module use /glade/p/ral/jntp/GMTB/tools/hpc-stack-v1.2.0/modulefiles/stack +module load hpc/1.2.0 +module load hpc-gnu/10.1.0 +module load hpc-mpt/2.22 + +module load jasper/2.0.25 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 + +module load bacio/2.4.1 +module load crtm/2.3.0 +module load g2/3.4.2 +module load g2tmpl/1.10.0 +module load ip/3.3.3 +module load nemsio/2.5.2 +module load sfcio/1.4.1 +module load sigio/2.3.2 +module load sp/2.3.3 +module load w3emc/2.9.2 +module load wrf_io/1.2.0 diff --git a/modulefiles/hera b/modulefiles/hera deleted file mode 100755 index af118011d..000000000 --- a/modulefiles/hera +++ /dev/null @@ -1,35 +0,0 @@ -#%Module###################################################################### -# Wen Meng 01/2021, Set up config. with the hpc-stack NCEPLIBS. -############################################################################## - -proc ModulesHelp { } { -puts stderr "Loads modules required for building upp" -} -module-whatis "Loads UPP prerequisites on Hera" - -module load cmake/3.16.1 - -module use /scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack -module load hpc/1.1.0 -module load hpc-intel/18.0.5.274 -module load hpc-impi/2018.0.4 - -module load jasper/2.0.22 -module load zlib/1.2.11 -module load png/1.6.35 - -module load hdf5/1.10.6 -module load netcdf/4.7.4 - -module load bacio/2.4.1 -module load crtm/2.3.0 -module load g2/3.4.1 -module load g2tmpl/1.10.0 -module load ip/3.3.3 -module load nemsio/2.5.2 -module load sfcio/1.4.1 -module load sigio/2.3.2 -module load sp/2.3.3 -module load w3nco/2.4.1 -module load w3emc/2.7.3 -module load wrf_io/1.1.1 diff --git a/modulefiles/hera.lua b/modulefiles/hera.lua new file mode 100644 index 000000000..a0e6574a7 --- /dev/null +++ b/modulefiles/hera.lua @@ -0,0 +1,58 @@ +help([[ +Load environment to build post on hera +]]) + +cmake_ver=os.getenv("cmake_ver") or "3.20.1" +load(pathJoin("cmake", cmake_ver)) + +prepend_path("MODULEPATH", "/scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack") + +hpc_ver=os.getenv("hpc_ver") or "1.1.0" +load(pathJoin("hpc", hpc_ver)) + +hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" +load(pathJoin("hpc-intel", hpc_intel_ver)) +hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" +load(pathJoin("hpc-impi", hpc_impi_ver)) + +hdf5_ver=os.getenv("hdf5_ver") or "1.10.6" +load(pathJoin("hdf5", hdf5_ver)) +netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +load(pathJoin("netcdf", netcdf_ver)) + +jasper_ver=os.getenv("jasper_ver") or "2.0.25" +load(pathJoin("jasper", jasper_ver)) +libpng_ver=os.getenv("libpng_ver") or "1.6.37" +load(pathJoin("libpng", libpng_ver)) +zlib_ver=os.getenv("zlib_ver") or "1.2.11" +load(pathJoin("zlib", zlib_ver)) + +g2_ver=os.getenv("g2_ver") or "3.4.5" +load(pathJoin("g2", g2_ver)) +g2tmpl_ver=os.getenv("g2tmpl_ver") or "1.10.0" +load(pathJoin("g2tmpl", g2tmpl_ver)) +bacio_ver=os.getenv("bacio_ver") or "2.4.1" +load(pathJoin("bacio", bacio_ver)) +ip_ver=os.getenv("ip_ver") or "3.3.3" +load(pathJoin("ip", ip_ver)) +sp_ver=os.getenv("sp_ver") or "2.3.3" +load(pathJoin("sp", sp_ver)) +crtm_ver=os.getenv("crtm_ver") or "2.3.0" +load(pathJoin("crtm", crtm_ver)) +w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +load(pathJoin("w3emc", w3emc_ver)) + +nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" +load(pathJoin("nemsio", nemsio_ver)) +sigio_ver=os.getenv("sigio_ver") or "2.3.2" +load(pathJoin("sigio", sigio_ver)) +sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" +load(pathJoin("sfcio", sfcio_ver)) +wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" +load(pathJoin("wrf_io", wrf_io_ver)) + +setenv("CC","mpiicc") +setenv("CXX","mpiicpc") +setenv("FC","mpiifort") + +whatis("Description: post build environment") diff --git a/modulefiles/jet b/modulefiles/jet old mode 100755 new mode 100644 index adafe445f..e789ff698 --- a/modulefiles/jet +++ b/modulefiles/jet @@ -30,6 +30,5 @@ module load nemsio/2.5.2 module load sfcio/1.4.1 module load sigio/2.3.2 module load sp/2.3.3 -module load w3nco/2.4.1 -module load w3emc/2.7.3 +module load w3emc/2.9.2 module load wrf_io/1.1.1 diff --git a/modulefiles/orion b/modulefiles/orion deleted file mode 100755 index 0fa59cec8..000000000 --- a/modulefiles/orion +++ /dev/null @@ -1,35 +0,0 @@ -#%Module###################################################################### -# Wen Meng 01/2021, Set up config. with the hpc-stack NCEPLIBS. -############################################################################## - -proc ModulesHelp { } { -puts stderr "Loads modules required for building upp" -} -module-whatis "Loads UPP prerequisites on Orion" - -module load cmake/3.17.3 - -module use /apps/contrib/NCEP/libs/hpc-stack/modulefiles/stack -module load hpc/1.1.0 -module load hpc-intel/2018.4 -module load hpc-impi/2018.4 - -module load jasper/2.0.22 -module load zlib/1.2.11 -module load png/1.6.35 - -module load hdf5/1.10.6 -module load netcdf/4.7.4 - -module load bacio/2.4.1 -module load crtm/2.3.0 -module load g2/3.4.1 -module load g2tmpl/1.10.0 -module load ip/3.3.3 -module load nemsio/2.5.2 -module load sfcio/1.4.1 -module load sigio/2.3.2 -module load sp/2.3.3 -module load w3nco/2.4.1 -module load w3emc/2.7.3 -module load wrf_io/1.1.1 diff --git a/modulefiles/orion.lua b/modulefiles/orion.lua new file mode 100644 index 000000000..2d39e1225 --- /dev/null +++ b/modulefiles/orion.lua @@ -0,0 +1,58 @@ +help([[ +Load environment to build post on orion +]]) + +cmake_ver=os.getenv("cmake_ver") or "3.22.1" +load(pathJoin("cmake", cmake_ver)) + +prepend_path("MODULEPATH", "/apps/contrib/NCEP/libs/hpc-stack/modulefiles/stack") + +hpc_ver=os.getenv("hpc_ver") or "1.1.0" +load(pathJoin("hpc", hpc_ver)) + +hpc_intel_ver=os.getenv("hpc_intel_ver") or "2022.1.2" +load(pathJoin("hpc-intel", hpc_intel_ver)) +hpc_impi_ver=os.getenv("hpc_impi_ver") or "2022.1.2" +load(pathJoin("hpc-impi", hpc_impi_ver)) + +hdf5_ver=os.getenv("hdf5_ver") or "1.10.6" +load(pathJoin("hdf5", hdf5_ver)) +netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +load(pathJoin("netcdf", netcdf_ver)) + +jasper_ver=os.getenv("jasper_ver") or "2.0.25" +load(pathJoin("jasper", jasper_ver)) +libpng_ver=os.getenv("libpng_ver") or "1.6.37" +load(pathJoin("libpng", libpng_ver)) +zlib_ver=os.getenv("zlib_ver") or "1.2.11" +load(pathJoin("zlib", zlib_ver)) + +g2_ver=os.getenv("g2_ver") or "3.4.5" +load(pathJoin("g2", g2_ver)) +g2tmpl_ver=os.getenv("g2tmpl_ver") or "1.10.0" +load(pathJoin("g2tmpl", g2tmpl_ver)) +bacio_ver=os.getenv("bacio_ver") or "2.4.1" +load(pathJoin("bacio", bacio_ver)) +ip_ver=os.getenv("ip_ver") or "3.3.3" +load(pathJoin("ip", ip_ver)) +sp_ver=os.getenv("sp_ver") or "2.3.3" +load(pathJoin("sp", sp_ver)) +crtm_ver=os.getenv("crtm_ver") or "2.3.0" +load(pathJoin("crtm", crtm_ver)) +w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +load(pathJoin("w3emc", w3emc_ver)) + +nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" +load(pathJoin("nemsio", nemsio_ver)) +sigio_ver=os.getenv("sigio_ver") or "2.3.2" +load(pathJoin("sigio", sigio_ver)) +sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" +load(pathJoin("sfcio", sfcio_ver)) +wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" +load(pathJoin("wrf_io", wrf_io_ver)) + +setenv("CC","mpiicc") +setenv("CXX","mpiicpc") +setenv("FC","mpiifort") + +whatis("Description: post build environment") diff --git a/modulefiles/post/v8.0.0-cray-intel b/modulefiles/post/v8.0.0-cray-intel deleted file mode 100644 index 529fb6c6b..000000000 --- a/modulefiles/post/v8.0.0-cray-intel +++ /dev/null @@ -1,60 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 - Branch based on current trunk as of 20151106 -## Luna Cray with Intel -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -module use -a /usrx/local/prod/modulefiles -module use -a /gpfs/hps/nco/ops/nwprod/lib/modulefiles -module load PrgEnv-intel -module rm intel -module load intel/18.1.163 -module rm NetCDF-intel-sandybridge/4.2 -module load craype-haswell -#module load craype/2.3.0 -module load cray-libsci/13.0.3 - -module load NetCDF-intel-sandybridge/4.7.4 -module load HDF5-parallel-intel-sandybridge/1.10.6 - -module load jasper-gnu-sandybridge/1.900.1 -module load png-gnu-sandybridge/1.2.49 -module load zlib-gnu-sandybridge/1.2.7 - -# Loading nceplibs modules -module load g2-intel/3.2.0 -module load g2tmpl-intel/1.6.0 -module load w3nco-intel/2.2.0 -module load bacio-intel/2.0.3 -module load gfsio-intel/1.1.0 -module load ip-intel/3.0.2 -module load sp-intel/2.0.3 -module load crtm-intel/2.3.0 -module load w3emc-intel/2.4.0 - -module load nemsio-intel/2.2.4 -module load sigio-intel/2.1.0 -module load sfcio-intel/1.0.0 -module load wrfio-intel/1.1.1 - -setenv myFC ftn -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O2 -convert big_endian -traceback -g -fp-model source -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" - -setenv mySFC ftn - - - diff --git a/modulefiles/post/v8.0.0-hera b/modulefiles/post/v8.0.0-hera deleted file mode 100644 index 72b80bc9e..000000000 --- a/modulefiles/post/v8.0.0-hera +++ /dev/null @@ -1,55 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for WCOSS production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -# Loading Intel Compiler Suite -module load intel/18.0.5.274 -module load impi/2018.0.4 - -module use /scratch1/NCEPDEV/nems/emc.nemspara/soft/modulefiles -module load hdf5_parallel/1.10.6 -module load netcdf_parallel/4.7.4 - -module use -a /scratch2/NCEPDEV/nwprod/NCEPLIBS/modulefiles -module load jasper/1.900.1 -module load png/1.2.44 -module load z/1.2.11 - -# Loding nceplibs modules -module load g2/3.2.0 -module load g2tmpl/1.6.0 -module load w3nco/2.2.0 -module load bacio/2.0.3 -module load gfsio/1.1.0 -module load ip/3.0.2 -module load sp/2.0.3 -module load crtm/2.3.0 -module load w3emc/2.4.0 - -module load nemsio/2.2.4 -module load sigio/2.1.1 -module load sfcio/1.1.1 -module load wrfio/1.1.1 - -setenv myFC mpiifort -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -# -#setenv myFCFLAGS "-O0 -convert big_endian -fp-model source -openmp -g -check all -ftrapuv -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" - -setenv mySFC ifort diff --git a/modulefiles/post/v8.0.0-jet b/modulefiles/post/v8.0.0-jet deleted file mode 100644 index b56a5c365..000000000 --- a/modulefiles/post/v8.0.0-jet +++ /dev/null @@ -1,52 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for WCOSS production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -# Loading Intel Compiler Suite -module load intel/18.0.5.274 -module load impi/2018.4.274 - -# Loding nceplibs modules -module use /mnt/lfs4/HFIP/hfv3gfs/nwprod/NCEPLIBS/modulefiles -module load sigio/v2.1.0 -module load jasper/v1.900.1 -module load png/v1.2.44 -module load z/v1.2.6 -module load sfcio/v1.0.0 -module load nemsio/v2.2.3 -module load bacio/v2.0.2 -module load xmlparse/v2.0.0 -module load gfsio/v1.1.0 -module load ip/v3.0.1 -module load sp/v2.0.2 -module load w3emc/v2.4.0 -module load w3nco/v2.0.6 -module load crtm/v2.3.0 -module load g2/v3.1.0 -module load g2tmpl/v1.6.0 -module load wrfio/v1.1.1 -module load hdf5_parallel/1.10.6 -module load netcdf_parallel/4.7.4 - - -#setenv WRFPATH /mnt/lfs3/projects/hfv3gfs/nwprod/wrf_shared.v1.1.0/ -setenv myFC mpiifort -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -# -#setenv myFCFLAGS "-O0 -convert big_endian -fp-model source -openmp -g -check all -ftrapuv -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" diff --git a/modulefiles/post/v8.0.0-odin b/modulefiles/post/v8.0.0-odin deleted file mode 100644 index cde6d1d3b..000000000 --- a/modulefiles/post/v8.0.0-odin +++ /dev/null @@ -1,87 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for WCOSS production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -#module purge - -# Loading Intel Compiler Suite -module load PrgEnv-intel -module swap intel/19.0.5.281 -module load cray-mpich/7.7.10 -module load cray-libsci -module load cray-netcdf-hdf5parallel -module load cray-parallel-netcdf -module load cray-hdf5-parallel -module load gcc/6.1.0 -module load slurm - -# Loding nceplibs modules -module use -a /oldscratch/ywang/external/modulefiles -module load sigio/v2.0.1 -#module load jasper/v1.900.1 -#module load png/v1.2.44 -#module load z/v1.2.6 -module load sfcio/v1.0.0 -module load nemsio/v2.2.2 -module load bacio/v2.0.2 -#module load g2/v2.5.2 -#module load xmlparse/v2.0.0 -module load gfsio/v1.1.0 -module load ip/v3.0.0 -module load sp/v2.0.2 -module load w3emc/v2.3.0 -module load w3nco/v2.0.6 -module load crtm/v2.2.5 -module load g2/v3.1.0 -module load g2tmpl/v1.5.0 -module load wrfio/1.1.1 -#module load netcdf/3.6.3 -#module load netcdf/4.6.1 - -setenv NETCDF /opt/cray/pe/netcdf-hdf5parallel/4.6.3.2/INTEL/19.0 -setenv JASPER_LIB "-ljasper" -setenv PNG_LIB "-lpng" - -#setenv NCEPLIBS /mnt/lfs3/projects/hfv3gfs/gwv/ljtjet/lib - -#module use /mnt/lfs3/projects/hfv3gfs/gwv/ljtjet/lib/modulefiles -#module load g2tmpl-intel/1.5.0 - -#module use /mnt/lfs3/projects/hfv3gfs/gwv/ljtjet/lib/wrf.post.lib/modulefiles -#module load wrf-io-v1.1.1 -# -#setenv WRFIO_LIB /mnt/lfs3/projects/hfv3gfs/gwv/ljtjet/lib/wrf.post.lib/v1.1.1/lib/wrf_io/libwrfio_nf.a - - -#set dlib /mnt/lfs3/projects/hfv3gfs/gwv/ltmp2/lib/g2/v3.1.0/ -#set bname "G2" -# -### Export environment variables -#setenv ${bname}_SRC $dlib/src -#setenv ${bname}_INC4 $dlib/intel/include/g2_v3.1.0_4 -#setenv ${bname}_INCd $dlib/intel/include/g2_v3.1.0_d -#setenv ${bname}_LIB4 $dlib/intel/libg2_v3.1.0_4.a -#setenv ${bname}_LIBd $dlib/intel/libg2_v3.1.0_d.a -#setenv ${bname}_VER v3.1.0 - -#setenv WRFPATH /mnt/lfs3/projects/hfv3gfs/nwprod/wrf_shared.v1.1.0/ -setenv myFC ftn -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp -target-cpu=x86-64" -# -#setenv myFCFLAGS "-O0 -convert big_endian -fp-model source -openmp -g -check all -ftrapuv -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" diff --git a/modulefiles/post/v8.0.0-orion b/modulefiles/post/v8.0.0-orion deleted file mode 100755 index cf7889526..000000000 --- a/modulefiles/post/v8.0.0-orion +++ /dev/null @@ -1,56 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for WCOSS production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -# Loading Intel Compiler Suite -module load intel/2018.4 -module load impi/2018.4 - -#module use /contrib/modulefiles -module use -a /apps/contrib/NCEPLIBS/orion/modulefiles - -module load netcdf_parallel/4.7.4 -module load hdf5_parallel/1.10.6 - -module load jasper/1.900.2 -module load png/1.2.44 -module load z/1.2.6 - -# Loding nceplibs modules -module load g2/3.2.0 -module load g2tmpl/1.6.0 -module load w3nco/2.2.0 -module load bacio/2.0.3 -module load gfsio/1.2.0 -module load ip/3.0.2 -module load sp/2.0.3 -module load crtm/2.3.0 -module load w3emc/2.4.0 - -module load nemsio/2.2.4 -module load sigio/2.2.0 -module load sfcio/1.2.0 -module load wrfio/1.1.1 - -setenv myFC mpiifort -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -# -#setenv myFCFLAGS "-O0 -convert big_endian -fp-model source -qopenmp -g -check all -ftrapuv -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" - -setenv mySFC ifort diff --git a/modulefiles/post/v8.0.0-stampede b/modulefiles/post/v8.0.0-stampede deleted file mode 100644 index 95ad14a5c..000000000 --- a/modulefiles/post/v8.0.0-stampede +++ /dev/null @@ -1,54 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for WCOSS production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -# Loading Intel Compiler Suite -module purge -module load intel/18.0.2 -module load impi/18.0.2 -module load parallel-netcdf/4.6.2 -module load phdf5/1.10.4 - -# Loding nceplibs modules -#module use -a /mnt/lfs3/projects/hfv3gfs/nwprod/lib/modulefiles -module use -a /work/00315/tg455890/stampede2/external/modulefiles -module load sigio/v2.1.0 -module load sfcio/v1.0.0 -module load nemsio/v2.2.3 -module load bacio/v2.0.2 -#module load g2/v2.5.2 -#module load xmlparse/v2.0.0 -module load gfsio/v1.1.0 -module load ip/v3.0.0 -module load sp/v2.0.2 -module load w3emc/v2.3.0 -module load w3nco/v2.0.6 -module load crtm/v2.2.3 -module load g2/v3.1.0 -module load g2tmpl/v1.6.0 -module load wrfio/1.1.1 - -setenv NETCDF /opt/apps/intel18/netcdf/4.6.2/x86_64 -setenv JASPER_LIB "-ljasper" -setenv PNG_LIB "-lpng" - -setenv myFC mpiifort -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -# -#setenv myFCFLAGS "-O0 -convert big_endian -fp-model source -openmp -g -check all -ftrapuv -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" diff --git a/modulefiles/post/v8.0.0-wcoss b/modulefiles/post/v8.0.0-wcoss deleted file mode 100644 index 38cf2801b..000000000 --- a/modulefiles/post/v8.0.0-wcoss +++ /dev/null @@ -1,45 +0,0 @@ -#%Module###################################################################### -############################################################# -## Lin.Gan@noaa.gov -## EMC -## post v7.0.0 -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for WCOSS production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -# Loading Intel Compiler Suite -module load ics/15.0.3 -module load ibmpe/1.3.0.12 - -# Loding nceplibs modules -module load sigio/v2.1.0 -module load jasper/v1.900.1 -module load png/v1.2.44 -module load z/v1.2.6 -module load sfcio/v1.0.0 -module load nemsio/v2.2.2 -module load bacio/v2.0.1 -module load g2/v3.1.0 -module load xmlparse/v2.0.0 -module load gfsio/v1.1.0 -module load ip/v3.0.0 -module load sp/v2.0.2 -module load w3emc/v2.2.0 -module load w3nco/v2.0.6 -module load crtm/v2.2.4 -module load NetCDF/3.6.3 -module load g2tmpl/v1.5.0 - -setenv WRFPATH /nwprod/sorc/wrf_shared.v1.1.0 -setenv myFC mpiifort -setenv OPENMP "-openmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -openmp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" diff --git a/modulefiles/post/v8.0.0-wcoss_dell_p3 b/modulefiles/post/v8.0.0-wcoss_dell_p3 deleted file mode 100644 index 8056ecac5..000000000 --- a/modulefiles/post/v8.0.0-wcoss_dell_p3 +++ /dev/null @@ -1,54 +0,0 @@ -#%Module###################################################################### -############################################################# -## post v7.0.0 - for WCOSS Dell -## Wen Meng 07/2018: set post to v8.0.0 for fv3gfs -############################################################# -proc ModulesHelp { } { -puts stderr "Set environment veriables for post" -puts stderr "This module initializes the users environment" -puts stderr "to build the post for production.\n" -} -module-whatis "post" - -set ver v8.0.0 - -module load ips/18.0.1.163 -module load impi/18.0.1 -#module load prod_util/1.1.0 - -module load NetCDF-parallel/4.7.4 -module load HDF5-parallel/1.10.6 - -module load jasper/1.900.1 -module load libpng/1.2.59 -module load zlib/1.2.11 - -# Loading nceplibs modules -module load g2/3.2.0 -module load g2tmpl/1.6.0 -module load w3nco/2.2.0 -module load bacio/2.0.3 -module load gfsio/1.1.0 -module load ip/3.0.2 -module load sp/2.0.3 -module load crtm/2.3.0 -module load w3emc/2.4.0 - -module load nemsio/2.2.4 -module load sigio/2.1.0 -module load sfcio/1.0.0 -module load wrfio/1.1.1 - -setenv myFC mpiifort -setenv OPENMP "-qopenmp" -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -#setenv myFCFLAGS "-g -O0 -check -check noarg_temp_created -check nopointer -fp-stack-check -fstack-protector-all -fpe0 -debug -traceback -ftrapuv" -##setenv myCPPFLAGS "-O0 -g -ftrapuv -traceback" - - -setenv mySFC ifort - - - diff --git a/modulefiles/s4 b/modulefiles/s4 index 3147aa294..f41835c42 100644 --- a/modulefiles/s4 +++ b/modulefiles/s4 @@ -29,6 +29,5 @@ module load nemsio/2.5.2 module load sfcio/1.4.1 module load sigio/2.3.2 module load sp/2.3.3 -module load w3nco/2.4.1 -module load w3emc/2.7.3 +module load w3emc/2.9.2 module load wrf_io/1.1.1 diff --git a/modulefiles/upp/lib-cray-intel b/modulefiles/upp/lib-cray-intel deleted file mode 100755 index 0233f4be4..000000000 --- a/modulefiles/upp/lib-cray-intel +++ /dev/null @@ -1,57 +0,0 @@ -#%Module###################################################################### -## Jun.Wang@noaa.gov: Started NCEPPOST lib v6.3.0 -## Wen.Meng@noaa.gov 10/2019: Upgraded to v8.0.0 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for NCEPPOST" -puts stderr "This module initializes the enviro nment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NCEPPOST lib whatis description" - -#set ver v6.3.0 -#set envir dev -#set NCEPLIB /nwprod/lib - -#set sys [uname sysname] - -#setenv COMPF_MP mpiifort -setenv myFC ftn -setenv myFCFLAGS "-O2 -convert big_endian -traceback -g -fp-model source -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -setenv ARCHV ar -setenv CPPC /lib/cpp -#setenv version v8.0.0 -# - -module purge - -module use -a /usrx/local/prod/modulefiles -module use -a /gpfs/hps/nco/ops/nwprod/lib/modulefiles - -# Loading Intel Compiler Suite -module load PrgEnv-intel -module rm intel -module load intel/18.1.163 -module load craype-haswell -#module load craype/2.3.0 - -module load jasper-gnu-sandybridge/1.900.1 -module load png-gnu-sandybridge/1.2.49 -module load zlib-gnu-sandybridge/1.2.7 - -# Loading nceplibs modules -module load g2-intel/3.2.0 -module load g2tmpl-intel/1.6.0 -#module load xmlparse/v2.0.0 -module load w3nco-intel/2.2.0 -module load bacio-intel/2.0.3 -module load gfsio-intel/1.1.0 -#module load sigio/2.1.0 -module load ip-intel/3.0.2 -module load sp-intel/2.0.3 -module load crtm-intel/2.3.0 -module load w3emc-intel/2.4.0 - - diff --git a/modulefiles/upp/lib-hera b/modulefiles/upp/lib-hera deleted file mode 100755 index 392989db4..000000000 --- a/modulefiles/upp/lib-hera +++ /dev/null @@ -1,52 +0,0 @@ -#%Module###################################################################### -## Jun.Wang@noaa.gov: Started NCEPPOST lib v6.3.0 -## Wen.Meng@noaa.gov 10/2019: Upgraded to v8.0.0 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for NCEPPOST" -puts stderr "This module initializes the enviro nment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NCEPPOST lib whatis description" - -#set ver v6.3.0 -#set envir dev -#set NCEPLIB /nwprod/lib - -#set sys [uname sysname] - -#setenv COMPF_MP mpiifort -setenv myFC mpiifort -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -setenv ARCHV ar -setenv CPPC /lib/cpp -#setenv version v8.0.0 -# - -module purge - -# Loading Intel Compiler Suite -module load intel/18.0.5.274 -module load impi/2018.0.4 - -# Loading nceplibs modules -module use -a /scratch2/NCEPDEV/nwprod/NCEPLIBS/modulefiles -module load jasper/1.900.1 -module load png/1.2.44 -module load z/1.2.11 - -module load g2/3.2.0 -module load g2tmpl/1.6.0 -#module load xmlparse/v2.0.0 -module load w3nco/2.2.0 -module load bacio/2.0.3 -module load gfsio/1.1.0 -#module load sigio/2.1.1 -module load ip/3.0.2 -module load sp/2.0.3 -module load crtm/2.3.0 -module load w3emc/2.4.0 - - diff --git a/modulefiles/upp/lib-jet b/modulefiles/upp/lib-jet deleted file mode 100755 index c9d9cb005..000000000 --- a/modulefiles/upp/lib-jet +++ /dev/null @@ -1,52 +0,0 @@ -#%Module###################################################################### -## Jun.Wang@noaa.gov: Started NCEPPOST lib v6.3.0 -## Wen.Meng@noaa.gov 10/2019: Upgraded to v8.0.0 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for NCEPPOST" -puts stderr "This module initializes the enviro nment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NCEPPOST lib whatis description" - -#set ver v6.3.0 -#set envir dev -#set NCEPLIB /nwprod/lib - -#set sys [uname sysname] - -#setenv COMPF_MP mpiifort -setenv myFC mpiifort -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -setenv ARCHV ar -setenv CPPC /lib/cpp -setenv version v8.0.0 -# - -module purge - -# Loading Intel Compiler Suite -module load intel/18.0.5.274 -module load impi/2018.4.274 - -# Loading nceplibs modules -module use /mnt/lfs4/HFIP/hfv3gfs/nwprod/NCEPLIBS/modulefiles -module load jasper/v1.900.1 -module load png/v1.2.44 -module load z/v1.2.6 -module load g2/v3.1.0 -module load g2tmpl/v1.6.0 -#module load xmlparse/v2.0.0 - -module load w3emc/v2.4.0 -module load w3nco/v2.0.6 -module load bacio/v2.0.2 -module load gfsio/v1.1.0 -#module load sigio/2.1.1 -module load ip/v3.0.1 -module load sp/v2.0.2 -module load crtm/v2.3.0 - - diff --git a/modulefiles/upp/lib-orion b/modulefiles/upp/lib-orion deleted file mode 100755 index 7459163ba..000000000 --- a/modulefiles/upp/lib-orion +++ /dev/null @@ -1,53 +0,0 @@ -#%Module###################################################################### -## Jun.Wang@noaa.gov: Started NCEPPOST lib v6.3.0 -## Wen.Meng@noaa.gov 10/2019: Upgraded to v8.0.0 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for NCEPPOST" -puts stderr "This module initializes the enviro nment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NCEPPOST lib whatis description" - -#set ver v6.3.0 -#set envir dev -#set NCEPLIB /nwprod/lib - -#set sys [uname sysname] - -#setenv COMPF_MP mpiifort -setenv myFC mpiifort -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -fpp" -#setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -setenv ARCHV ar -setenv CPPC /lib/cpp -#setenv version v8.0.0 -# - -module purge - -# Loading Intel Compiler Suite -module load intel/2018.4 -module load impi/2018.4 - -# Loading nceplibs modules -module use -a /apps/contrib/NCEPLIBS/orion/modulefiles -module load jasper/1.900.2 -module load png/1.2.44 -module load z/1.2.6 - -module load g2/3.2.0 -module load g2tmpl/1.6.0 -#module load xmlparse/v2.0.0 -module load w3nco/2.2.0 -module load bacio/2.0.3 -module load gfsio/1.2.0 -#module load sigio/2.1.0 -module load ip/3.0.2 -module load sp/2.0.3 -module load crtm/2.3.0 -module load w3emc/2.4.0 - - diff --git a/modulefiles/upp/lib-wcoss b/modulefiles/upp/lib-wcoss deleted file mode 100755 index 7fa2710b6..000000000 --- a/modulefiles/upp/lib-wcoss +++ /dev/null @@ -1,54 +0,0 @@ -#%Module###################################################################### -## Jun.Wang@noaa.gov: Started NCEPPOST lib v6.3.0 -## Wen.Meng@noaa.gov 10/2019: Upgraded to v8.0.0 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for NCEPPOST" -puts stderr "This module initializes the enviro nment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NCEPPOST lib whatis description" - -#set ver v6.3.0 -#set envir dev -#set NCEPLIB /nwprod/lib - -#set sys [uname sysname] - -#setenv COMPF_MP mpiifort -setenv myFC mpiifort -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -setenv ARCHV ar -setenv CPPC /lib/cpp -setenv version v8.0.0 -# - -module purge - -# Loading Intel Compiler Suite -module load ics/16.0.3 -module load ibmpe -#module load ics/15.0.3 -##module load ibmpe/1.3.0.12 -#module load prod_util/1.1.0 - -# Loading nceplibs modules -module load jasper/v1.900.1 -module load png/v1.2.44 -module load z/v1.2.6 -module load g2/v3.1.0 -module load g2tmpl/v1.5.0 -#module load xmlparse/v2.0.0 - -module load w3emc/v2.2.0 -module load w3nco/v2.0.6 -module load bacio/v2.0.1 -module load gfsio/v1.1.0 -#module load sigio/2.1.0 -module load ip/v3.0.1 -module load sp/v2.0.2 -module load crtm/v2.2.4 - - diff --git a/modulefiles/upp/lib-wcoss_dell_p3 b/modulefiles/upp/lib-wcoss_dell_p3 deleted file mode 100755 index 94eea42e4..000000000 --- a/modulefiles/upp/lib-wcoss_dell_p3 +++ /dev/null @@ -1,53 +0,0 @@ -#%Module###################################################################### -## Jun.Wang@noaa.gov: Started NCEPPOST lib v6.3.0 -## Wen.Meng@noaa.gov 10/2019: Upgraded to v8.0.0 -##_____________________________________________________ -proc ModulesHelp { } { -puts stderr "Set environment veriables for NCEPPOST" -puts stderr "This module initializes the enviro nment " -puts stderr "for the Intel Compiler Suite $version\n" -} -module-whatis " NCEPPOST lib whatis description" - -#set ver v6.3.0 -#set envir dev -#set NCEPLIB /nwprod/lib - -#set sys [uname sysname] - -#setenv COMPF_MP mpiifort -setenv myFC mpiifort -setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -fpp" -#setenv myFCFLAGS "-O3 -convert big_endian -traceback -g -fp-model source -qopenmp -fpp" -setenv myCPP /lib/cpp -setenv myCPPFLAGS "-P" -setenv ARCHV ar -setenv CPPC /lib/cpp -#setenv version v8.0.0 -# - -module purge - -# Loading Intel Compiler Suite -module load ips/18.0.1.163 -module load impi/18.0.1 - -module load jasper/1.900.1 -module load libpng/1.2.59 -module load zlib/1.2.11 - - -# Loading nceplibs modules -module load g2/3.2.0 -module load g2tmpl/1.6.0 -#module load xmlparse/v2.0.0 -module load w3nco/2.2.0 -module load bacio/2.0.3 -module load gfsio/1.1.0 -#module load sigio/2.1.0 -module load ip/3.0.2 -module load sp/2.0.3 -module load crtm/2.3.0 -module load w3emc/2.4.0 - - diff --git a/modulefiles/wcoss2.lua b/modulefiles/wcoss2.lua new file mode 100644 index 000000000..e18bbce62 --- /dev/null +++ b/modulefiles/wcoss2.lua @@ -0,0 +1,54 @@ +help([[ +Load environment to build post on WCOSS2 +]]) + +PrgEnv_intel_ver=os.getenv("PrgEnv_intel_ver") or "8.1.0" +intel_ver=os.getenv("intel_ver") or "19.1.3.304" +craype_ver=os.getenv("craype_ver") or "2.7.10" +cray_mpich_ver=os.getenv("cray_mpich_ver") or "8.1.9" +load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver)) +load(pathJoin("intel", intel_ver)) +load(pathJoin("craype", craype_ver)) +load(pathJoin("cray-mpich", cray_mpich_ver)) + +hdf5_ver=os.getenv("hdf5_ver") or "1.10.6" +netcdf_ver=os.getenv("netcdf_ver") or "4.7.4" +load(pathJoin("hdf5", hdf5_ver)) +load(pathJoin("netcdf", netcdf_ver)) + +jasper_ver=os.getenv("jasper_ver") or "2.0.25" +libpng_ver=os.getenv("libpng_ver") or "1.6.37" +zlib_ver=os.getenv("zlib_ver") or "1.2.11" +load(pathJoin("jasper", jasper_ver)) +load(pathJoin("libpng", libpng_ver)) +load(pathJoin("zlib", zlib_ver)) + +g2_ver=os.getenv("g2_ver") or "3.4.5" +g2tmpl_ver=os.getenv("g2tmpl_ver") or "1.10.0" +bacio_ver=os.getenv("bacio_ver") or "2.4.1" +ip_ver=os.getenv("ip_ver") or "3.3.3" +sp_ver=os.getenv("sp_ver") or "2.3.3" +crtm_ver=os.getenv("crtm_ver") or "2.3.0" +w3emc_ver=os.getenv("w3emc_ver") or "2.9.2" +load(pathJoin("g2", g2_ver)) +load(pathJoin("g2tmpl", g2tmpl_ver)) +load(pathJoin("bacio", bacio_ver)) +load(pathJoin("ip", ip_ver)) +load(pathJoin("sp", sp_ver)) +load(pathJoin("crtm", crtm_ver)) +load(pathJoin("w3emc", w3emc_ver)) + +nemsio_ver=os.getenv("nemsio_ver") or "2.5.2" +sigio_ver=os.getenv("sigio_ver") or "2.3.2" +sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" +wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" +load(pathJoin("nemsio", nemsio_ver)) +load(pathJoin("sigio", sigio_ver)) +load(pathJoin("sfcio", sfcio_ver)) +load(pathJoin("wrf_io", wrf_io_ver)) + +setenv("CC","cc") +setenv("CXX","CC") +setenv("FC","ftn") + +whatis("Description: post build environment") diff --git a/modulefiles/wcoss_cray b/modulefiles/wcoss_cray old mode 100755 new mode 100644 index 72457d598..f8866064d --- a/modulefiles/wcoss_cray +++ b/modulefiles/wcoss_cray @@ -36,6 +36,5 @@ module load nemsio/2.5.2 module load sfcio/1.4.1 module load sigio/2.3.2 module load sp/2.3.3 -module load w3nco/2.4.1 -module load w3emc/2.7.3 +module load w3emc/2.9.2 module load wrf_io/1.1.1 diff --git a/modulefiles/wcoss_dell_p3 b/modulefiles/wcoss_dell_p3 old mode 100755 new mode 100644 index c6692ecfa..e8821e22d --- a/modulefiles/wcoss_dell_p3 +++ b/modulefiles/wcoss_dell_p3 @@ -30,6 +30,5 @@ module load nemsio/2.5.2 module load sfcio/1.4.1 module load sigio/2.3.2 module load sp/2.3.3 -module load w3nco/2.4.1 -module load w3emc/2.7.3 +module load w3emc/2.9.2 module load wrf_io/1.1.1 diff --git a/parm/fv3lam_rrfs.xml b/parm/fv3lam_rrfs.xml index 61ee45d87..1f6bd8af9 100755 --- a/parm/fv3lam_rrfs.xml +++ b/parm/fv3lam_rrfs.xml @@ -1466,22 +1466,22 @@ UEID_ON_EFL -1.0 - + VEID_ON_EFL -1.0 - + E3KH_ON_EFL -1.0 - + STPC_ON_EFL -1.0 - + SIGT_ON_EFL -1.0 diff --git a/parm/post_avblflds.xml b/parm/post_avblflds.xml index 4678fc666..89065f857 100755 --- a/parm/post_avblflds.xml +++ b/parm/post_avblflds.xml @@ -6299,16 +6299,17 @@ 685 - DU_CR_AER_SFC_MASS_CON + DUST10_SFC_MASS_CON AVE tmpl4_48 - MASSDEN + PMTC + surface dust_dry smaller_than_first_limit 6 10 surface - 9.0 + 9.0 diff --git a/parm/post_tag_gfs128 b/parm/post_tag_gfs128 index 9a9a3bdde..f9246e045 100644 --- a/parm/post_tag_gfs128 +++ b/parm/post_tag_gfs128 @@ -1,3 +1,6 @@ +&MODEL_INPUTS +MODELNAME='GFS' +/ &NAMPGB KPO=57,PO=1000.,975.,950.,925.,900.,875.,850.,825.,800.,775.,750.,725.,700.,675.,650.,625.,600.,575.,550.,525.,500.,475.,450.,425.,400.,375.,350.,325.,300.,275.,250.,225.,200.,175.,150.,125.,100.,70.,50.,40.,30.,20.,15.,10.,7.,5.,3.,2.,1.,0.7,0.4,0.2,0.1,0.07,0.04,0.02,0.01, / diff --git a/parm/post_tag_gfs65 b/parm/post_tag_gfs65 index 2653fea19..7643b75d7 100644 --- a/parm/post_tag_gfs65 +++ b/parm/post_tag_gfs65 @@ -1,3 +1,6 @@ +&MODEL_INPUTS +MODELNAME='GFS' +/ &NAMPGB KPO=50,PO=1000.,975.,950.,925.,900.,875.,850.,825.,800.,775.,750.,725.,700.,675.,650.,625.,600.,575.,550.,525.,500.,475.,450.,425.,400.,375.,350.,325.,300.,275.,250.,225.,200.,175.,150.,125.,100.,70.,50.,40.,30.,20.,15.,10.,7.,5.,3.,2.,1.,0.4, / diff --git a/parm/postcntrl_gefs_chem.xml b/parm/postcntrl_gefs_chem.xml index c4ce522cf..5abf7128b 100755 --- a/parm/postcntrl_gefs_chem.xml +++ b/parm/postcntrl_gefs_chem.xml @@ -225,6 +225,12 @@ 9.0 + + DUST10_SFC_MASS_CON + NCEP + 9.0 + + DUST25_SFC_MASS_CON NCEP diff --git a/scripts/exgdas_atmos_nceppost.sh b/scripts/exgdas_atmos_nceppost.sh index 0faec53c6..dc7b12698 100755 --- a/scripts/exgdas_atmos_nceppost.sh +++ b/scripts/exgdas_atmos_nceppost.sh @@ -16,6 +16,9 @@ echo " Feb 18 - Meng - Removed legacy setting for generating grib1 data" echo " and reading sigio model outputs." echo " Aug 20 - Meng - Remove .ecf extentsion per EE2 review." echo " Sep 20 - Meng - Update clean up files per EE2 review." +echo " Mar 21 - Meng - Update POSTGRB2TBL default setting." +echo " Oct 21 - Meng - Remove jlogfile for wcoss2 transition." +echo " Feb 22 - Lin - Exception handling if anl input not found." echo "-----------------------------------------------------" ##################################################################### @@ -24,7 +27,7 @@ set -x cd $DATA msg="HAS BEGUN on `hostname`" -postmsg "$jlogfile" "$msg" +postmsg "$msg" export POSTGPSH=${POSTGPSH:-$USHgfs/gfs_nceppost.sh} export GFSDOWNSH=${GFSDOWNSH:-$USHgfs/fv3gfs_downstream_nems.sh} @@ -176,6 +179,11 @@ then fi rm pgbfile.grib2 +else + #### atmanl file not found need failing job + echo " *** FATAL ERROR: No model anl file output " + export err=9 + err_chk fi #---------------------------------- @@ -221,7 +229,7 @@ do set -x msg="Starting post for fhr=$fhr" - postmsg "$jlogfile" "$msg" + postmsg "$msg" ############################### # Put restart files into /nwges diff --git a/scripts/exgfs_atmos_nceppost.sh b/scripts/exgfs_atmos_nceppost.sh index 199c1dc1f..f8e996d13 100755 --- a/scripts/exgfs_atmos_nceppost.sh +++ b/scripts/exgfs_atmos_nceppost.sh @@ -25,6 +25,12 @@ echo " Feb 18 - Meng - Removed legacy setting for generating grib1 data" echo " and reading sigio model outputs." echo " Aug 20 - Meng - Remove .ecf extentsion per EE2 review." echo " Sep 20 - Meng - Update clean up files per EE2 review." +echo " Dec 20 - Meng - Add alert for special data file." +echo " Mar 21 - Meng - Update POSTGRB2TBL default setting." +echo " Jun 21 - Mao - Instead of err_chk, catch err and print out" +echo " WAFS failure warnings to avoid job crashing" +echo " Oct 21 - Meng - Remove jlogfile for wcoss2 transition." +echo " Feb 22 - Lin - Exception handling if anl input not found." echo "-----------------------------------------------------" ##################################################################### @@ -34,7 +40,7 @@ cd $DATA # specify model output format type: 4 for nemsio, 3 for sigio msg="HAS BEGUN on `hostname`" -postmsg "$jlogfile" "$msg" +postmsg "$msg" export POSTGPSH=${POSTGPSH:-$USHgfs/gfs_nceppost.sh} export GFSDOWNSH=${GFSDOWNSH:-$USHgfs/fv3gfs_downstream_nems.sh} @@ -201,31 +207,40 @@ then export PGIOUT=wafsifile $POSTGPSH - export err=$?; err_chk + export err=$? - # WAFS package doesn't process this part. - # Need to be saved for WAFS U/V/T verification, - # resolution higher than WAFS 1.25 deg for future compatibility - wafsgrid="latlon 0:1440:0.25 90:721:-0.25" - $WGRIB2 $PGBOUT -set_grib_type same -new_grid_winds earth \ + if [ $err -ne 0 ] ; then + echo " *** GFS POST WARNING: WAFS output failed for analysis, err=$err" + else + + # WAFS package doesn't process this part. + # Need to be saved for WAFS U/V/T verification, + # resolution higher than WAFS 1.25 deg for future compatibility + wafsgrid="latlon 0:1440:0.25 90:721:-0.25" + $WGRIB2 $PGBOUT -set_grib_type same -new_grid_winds earth \ -new_grid_interpolation bilinear -set_bitmap 1 \ -new_grid $wafsgrid ${PGBOUT}.tmp - if test $SENDCOM = "YES" - then + if test $SENDCOM = "YES" + then cp ${PGBOUT}.tmp $COMOUT/${PREFIX}wafs.0p25.anl $WGRIB2 -s ${PGBOUT}.tmp > $COMOUT/${PREFIX}wafs.0p25.anl.idx - if [ $SENDDBN = YES ]; then - $DBNROOT/bin/dbn_alert MODEL GFS_WAFS_GB2 $job $COMOUT/${PREFIX}wafs.0p25.anl - $DBNROOT/bin/dbn_alert MODEL GFS_WAFS_GB2__WIDX $job $COMOUT/${PREFIX}wafs.0p25.anl.idx - fi +# if [ $SENDDBN = YES ]; then +# $DBNROOT/bin/dbn_alert MODEL GFS_WAFS_GB2 $job $COMOUT/${PREFIX}wafs.0p25.anl +# $DBNROOT/bin/dbn_alert MODEL GFS_WAFS_GB2__WIDX $job $COMOUT/${PREFIX}wafs.0p25.anl.idx +# fi + fi + rm $PGBOUT ${PGBOUT}.tmp fi - rm $PGBOUT ${PGBOUT}.tmp fi fi ########################## WAFS U/V/T analysis end ########################## - +else + #### atmanl file not found need failing job + echo " *** FATAL ERROR: No model anl file output " + export err=9 + err_chk fi #---------------------------------- @@ -273,7 +288,7 @@ do set -x msg="Starting post for fhr=$fhr" - postmsg "$jlogfile" "$msg" + postmsg "$msg" ############################### # Put restart files into /nwges @@ -487,6 +502,10 @@ do mv goesfile $COMOUT/${SPECIALFL}f$fhr mv goesifile $COMOUT/${SPECIALFLIDX}f$fhr + if [ $SENDDBN = YES ]; then + $DBNROOT/bin/dbn_alert MODEL GFS_SPECIAL_GB2 $job $COMOUT/${SPECIALFL}f$fhr + fi + fi fi # end of satellite processing @@ -523,16 +542,20 @@ do $POSTGPSH fi - export err=$?; err_chk - - if [ -e $PGBOUT ] - then - if test $SENDCOM = "YES" - then - cp $PGBOUT $COMOUT/${PREFIX}wafs.grb2f$fhr - cp $PGIOUT $COMOUT/${PREFIX}wafs.grb2if$fhr - fi - fi + export err=$? + + if [ $err -ne 0 ] ; then + echo " *** GFS POST WARNING: WAFS output failed for f${fhr}, err=$err" + else + if [ -e $PGBOUT ] + then + if test $SENDCOM = "YES" + then + cp $PGBOUT $COMOUT/${PREFIX}wafs.grb2f$fhr + cp $PGIOUT $COMOUT/${PREFIX}wafs.grb2if$fhr + fi + fi + fi fi [[ -f wafsfile ]] && rm wafsfile ; [[ -f wafsifile ]] && rm wafsifile fi diff --git a/scripts/exglobal_atmos_pmgr.sh b/scripts/exglobal_atmos_pmgr.sh index 58784241c..a9bcb4251 100755 --- a/scripts/exglobal_atmos_pmgr.sh +++ b/scripts/exglobal_atmos_pmgr.sh @@ -67,7 +67,7 @@ do sleep 10 icnt=$((icnt + 1)) - if [ $icnt -ge 1001 ] + if [ $icnt -ge 1080 ] then msg="ABORTING after 3 hours of waiting for ${RUN} FCST hours $postjobs." err_exit $msg diff --git a/scripts/run_upp b/scripts/run_upp index ee2c04e37..39cc9a986 100755 --- a/scripts/run_upp +++ b/scripts/run_upp @@ -22,6 +22,10 @@ set -x # October 2020: Modified to remove WRF and grib1; Add FV3LAM # Updates for cmake build, Change exec name # +# May 2022: Modified to remove binarynemsiompiio; +# Added netcdfpara; Removed netcdf; +# Changed UPP directory name and path +# #-------------------------------------------------------- # # This script runs the stand-alone community version of UPP @@ -31,11 +35,11 @@ set -x #---------------------------------------------------------------------------------- #--- USER EDIT DESCIPTIONS -------------------------------------------------------- # See UPP User's Guide for more information -# https://upp.readthedocs.io/en/ufs-v2.0.0/ +# https://upp.readthedocs.io/en/latest/ #---------------------------------------------------------------------------------- # TOP_DIR : Top level directory for building and running UPP # DOMAINPATH : Working directory for this run. -# UNIPOST_HOME : Location of the EMC-post directory +# UPP_HOME : Location of the UPP directory # POSTEXEC : Location of the UPP executable # modelDataPath : Location of the model output data files to be post-processed # txtCntrlFile : Name and location of the flat text file that lists desired fields for output @@ -44,8 +48,8 @@ set -x # LAM (Limited Area Model): postxconfig-NT-fv3lam.txt # model : What model is used? GFS or LAM (Limited Area Model) # inFormat : Format of the model data -# GFS - "binarynemsiompiio" or "netcdf" -# LAM - "netcdf" +# GFS - "netcdfpara" +# LAM - "netcdfpara" # outFormat : Format of output from UPP # grib2 # startdate : Forecast start date (YYYYMMDDHH) @@ -64,8 +68,8 @@ set -x # as recommended in the users guide where UPP will output. export TOP_DIR=/home/username export DOMAINPATH=${TOP_DIR}/test_case -export UNIPOST_HOME=${TOP_DIR}/EMC_post -export POSTEXEC=${UNIPOST_HOME}/bin +export UPP_HOME=${TOP_DIR}/UPP +export POSTEXEC=${UPP_HOME}/tests/install/bin export modelDataPath=/path/to/model/data export txtCntrlFile=${DOMAINPATH}/parm/postxconfig-NT-GFS.txt @@ -73,7 +77,7 @@ export txtCntrlFile=${DOMAINPATH}/parm/postxconfig-NT-GFS.txt export model="GFS" # Set input format from model and ouput format from UPP -export inFormat="netcdf" +export inFormat="netcdfpara" export outFormat="grib2" # Set date/time information @@ -92,9 +96,6 @@ export RUN_COMMAND="mpirun -np 1 ${POSTEXEC}/upp.x " #export RUN_COMMAND="mpirun.lsf ${POSTEXEC}/upp.x " #export RUN_COMMAND="mpiexec_mpt ${POSTEXEC}/upp.x " -# DEBUG command example found further below, search "DEBUG" - - # Shouldn't need to edit these. # tmmark is an variable used as the file extention of the output # filename .GrbF is used if this variable is not set @@ -135,17 +136,17 @@ else fi if [ ${model} == "GFS" ]; then - if [[ ${inFormat} == "binarynemsiompiio" ]]; then - echo "Check: You are using 'model' 'inFormat'!" - elif [[ ${inFormat} == "netcdf" ]]; then + if [ ${inFormat} == "netcdfpara" ]; then echo "Check: You are using 'model' 'inFormat'!" else - echo "ERROR: 'inFormat' must be 'binarynemsiompiio' or 'netcdf' for GFS model output. Exiting... " + echo "ERROR: 'inFormat' must be 'netcdfpara' for GFS model output. Exiting... " exit 1 fi -elif [[ ${model} == "LAM" ]]; then - if [[ ${inFormat} != "netcdf" ]]; then - echo "ERROR: 'inFormat' must be 'netcdf' for LAM model output. Exiting... " +elif [ ${model} == "LAM" ]; then + if [ ${inFormat} == "netcdfpara" ]; then + echo "Check: You are using 'model' 'inFormat'!" + else + echo "ERROR: 'inFormat' must be 'netcdfpara' for LAM model output. Exiting... " exit 1 fi fi @@ -194,17 +195,17 @@ fi # file which defines the GRIB2 table values if [[ ${outFormat} == "grib2" ]]; then ln -fs ${txtCntrlFile} postxconfig-NT.txt - ln -fs ${UNIPOST_HOME}/parm/post_avblflds.xml post_avblflds.xml - ln -fs ${UNIPOST_HOME}/parm/params_grib2_tbl_new params_grib2_tbl_new + ln -fs ${UPP_HOME}/parm/post_avblflds.xml post_avblflds.xml + ln -fs ${UPP_HOME}/parm/params_grib2_tbl_new params_grib2_tbl_new fi # Link microphysics tables - code will use based on mp_physics option # found in data -ln -fs ${UNIPOST_HOME}/parm/nam_micro_lookup.dat . -ln -fs ${UNIPOST_HOME}/parm/hires_micro_lookup.dat . +ln -fs ${UPP_HOME}/parm/nam_micro_lookup.dat . +ln -fs ${UPP_HOME}/parm/hires_micro_lookup.dat . # link coefficients for crtm2 (simulated synthetic satellites) -CRTMDIR=${UNIPOST_HOME}/crtm/fix +CRTMDIR=${UPP_HOME}/crtm/fix ln -fs $CRTMDIR/EmisCoeff/IR_Water/Big_Endian/Nalli.IRwater.EmisCoeff.bin ./ ln -fs $CRTMDIR/EmisCoeff/MW_Water/Big_Endian/FASTEM4.MWwater.EmisCoeff.bin ./ ln -fs $CRTMDIR/EmisCoeff/MW_Water/Big_Endian/FASTEM5.MWwater.EmisCoeff.bin ./ @@ -289,17 +290,14 @@ echo 'YY' $YY # Create model file name (inFileName) if [ ${model} == "GFS" ]; then - if [[ ${inFormat} == "binarynemsiompiio" ]]; then - inFileName=${modelDataPath}/atmf${fhour}.nemsio - flxFileName=${modelDataPath}/sfcf${fhour}.nemsio - elif [ ${inFormat} == "netcdf" ]; then - inFileName=${modelDataPath}/atmf${fhour}.nc - flxFileName=${modelDataPath}/sfcf${fhour}.nc + if [ ${inFormat} == "netcdfpara" ]; then + inFileName=${modelDataPath}/gfs.t00z.atmf${fhour}.nc + flxFileName=${modelDataPath}/gfs.t00z.sfcf${fhour}.nc fi elif [ ${model} == "LAM" ]; then - if [ ${inFormat} == "netcdf" ]; then + if [ ${inFormat} == "netcdfpara" ]; then inFileName=${modelDataPath}/dynf${fhour}.nc - flxFileName=${modelDataPath}/dynf${fhour}.nc + flxFileName=${modelDataPath}/phyf${fhour}.nc fi fi diff --git a/sorc/build_ncep_post.sh b/sorc/build_ncep_post.sh deleted file mode 100755 index 93022e2f4..000000000 --- a/sorc/build_ncep_post.sh +++ /dev/null @@ -1,132 +0,0 @@ -#!/bin/bash -#################################################################################################### -# -# post using module compile standard -# -# 10/15 Lin Gan: Create module load version -# 01/16 Lin Gan: Update to use GFS Vertical Structure -# 07/16 J. Carley: Generalize for other machines using modules -# 07/18 Wen Meng: Set post to v8.0.0 for fv3gfs -# 10/19 M Kavulich: Provide machine name as an input argument -# -##################################################################################################### -##################################################################################################### - -#List of valid machines: -validmachines=(theia jet wcoss_dell_p3 wcoss cray-intel hera orion odin stampede s4) - -function usage { - echo "Usage:" - echo " $0 machinename" - echo "" - echo " Valid values for 'machinename' are: ${validmachines[@]}" - exit 1 -} - -if [ "$#" -eq 0 ]; then - #Check to see if we are building the old way - module purge - set -x - mac=$(hostname | cut -c1-1) - mac2=$(hostname | cut -c1-2) - if [ $mac2 = tf ] ; then # For Theia - machine=theia - elif [ $mac = f ] ; then # For Jet - machine=jet - elif [ $mac = v -o $mac = m ] ; then # For Dell - machine=wcoss_dell_p3 - elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS - machine=wcoss - elif [ $mac2 = s4 ] ; then # For S4 - machine=s4 - elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge) - export machine=cray-intel - elif [ $mac2 = hf ] ; then # For Hera - machine=hera - elif [ $mac = O ] ; then - machine=orion - elif [ $mac2 = od ] ; then - machine=odin - else - echo "" - echo "ERROR ERROR ERROR" - echo "" - echo "Error: To use this build script without arguments you must be on a valid machine" - echo "Valid machines are:" - echo "${validmachines[@]}" - echo "" - echo "ERROR ERROR ERROR" - fi - -elif [ "$#" -gt 1 ]; then - echo "Error: too many input arguments" - exit 2 -else - machine=$1 -fi - -# Lin Gan Module Load -set -x -case $machine in -theia) # For Theia - module purge - . /etc/profile - . /etc/profile.d/modules.sh - ;; -jet) # For Jet - module purge - . /etc/profile - . /etc/profile.d/modules.sh - ;; -wcoss_dell_p3) # For Dell - module purge - . $MODULESHOME/init/bash - ;; -wcoss) # For WCOSS - module purge - . /usrx/local/Modules/default/init/bash - ;; -cray-intel) # For wcoss_c (i.e. luna and surge) - module purge - ;; -hera) # For Hera - . /etc/profile - . /etc/profile.d/modules.sh - ;; -orion) # For Orion - . /etc/profile - ;; -odin) # For Odin at NSSL - . /etc/profile - . /etc/profile.d/modules.sh - ;; -stampede) - module purge - ;; -s4) # For S4 - . /etc/profile - ;; -*) - set +x - echo "ERROR: Invalid machine name specified" - usage - ;; -esac - -# Lin Gan modifiy to use NCO vertical structure prefix for NCO deployment - 20160131 -moduledir=`dirname $(readlink -f ../modulefiles/post)` -module use ${moduledir} -module load post/v8.0.0-${machine} -module list - -cd ncep_post.fd - -make -f makefile_module clean -make -f makefile_module - -if [ ! -d "../../exec" ] ; then - mkdir -p ../../exec -fi -cp ncep_post ../../exec/ - -exit 0 diff --git a/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f index 4643f84a5..a93741328 100644 --- a/sorc/ncep_post.fd/ALLOCATE_ALL.f +++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f @@ -18,6 +18,7 @@ !! - 21-04-06 Wen Meng - Initializing all allocated arrays !! - 21-04-16 Wen Meng - Initializing aextc55 and extc55 as 0. These !! two arrays are involved in GSL visibility computation. +!! - 22-03-22 Wen Meng - Initializing pwat. !! !! OUTPUT FILES: !! - STDOUT - RUN TIME STANDARD OUT. @@ -46,40 +47,40 @@ SUBROUTINE ALLOCATE_ALL() integer ierr,jsx,jex integer i,j,l,k ! Allocate arrays - allocate(u(im+1,jsta_2l:jend_2u,lm)) - allocate(v(im,jsta_2l:jvend_2u,lm)) - allocate(t(im,jsta_2l:jend_2u,lm)) + allocate(u(ista_2l:iend_2u+1,jsta_2l:jend_2u,lm)) + allocate(v(ista_2l:iend_2u,jsta_2l:jvend_2u,lm)) + allocate(t(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) ! CHUANG ADD POTENTIAL TEMP BECAUSE WRF OUTPUT THETA -! allocate(th(im,jsta_2l:jend_2u,lm)) - allocate(q(im,jsta_2l:jend_2u,lm)) -! allocate(w(im,jsta_2l:jend_2u,lp1)) - allocate(uh(im,jsta_2l:jend_2u,lm)) - allocate(vh(im,jsta_2l:jend_2u,lm)) - allocate(wh(im,jsta_2l:jend_2u,lm)) - allocate(pmid(im,jsta_2l:jend_2u,lm)) - allocate(pmidv(im,jsta_2l:jend_2u,lm)) - allocate(pint(im,jsta_2l:jend_2u,lp1)) - allocate(alpint(im,jsta_2l:jend_2u,lp1)) - allocate(zmid(im,jsta_2l:jend_2u,lm)) - allocate(zint(im,jsta_2l:jend_2u,lp1)) -! allocate(rainw(im,jsta_2l:jend_2u,lm)) - allocate(q2(im,jsta_2l:jend_2u,lm)) - allocate(omga(im,jsta_2l:jend_2u,lm)) - allocate(dpres(im,jsta_2l:jend_2u,lm)) - allocate(T_ADJ(im,jsta_2l:jend_2u,lm)) - allocate(ttnd(im,jsta_2l:jend_2u,lm)) - allocate(rswtt(im,jsta_2l:jend_2u,lm)) - allocate(rlwtt(im,jsta_2l:jend_2u,lm)) - allocate(exch_h(im,jsta_2l:jend_2u,lm)) - allocate(train(im,jsta_2l:jend_2u,lm)) - allocate(tcucn(im,jsta_2l:jend_2u,lm)) - allocate(EL_PBL(im,jsta_2l:jend_2u,lm)) +! allocate(th(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(q(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) +! allocate(w(ista_2l:iend_2u,jsta_2l:jend_2u,lp1)) + allocate(uh(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(vh(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(wh(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pmid(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pmidv(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pint(ista_2l:iend_2u,jsta_2l:jend_2u,lp1)) + allocate(alpint(ista_2l:iend_2u,jsta_2l:jend_2u,lp1)) + allocate(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(zint(ista_2l:iend_2u,jsta_2l:jend_2u,lp1)) +! allocate(rainw(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(q2(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(omga(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(dpres(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(T_ADJ(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ttnd(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(rswtt(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(rlwtt(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(exch_h(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(train(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(tcucn(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(EL_PBL(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im+1 + do i=ista_2l,iend_2u+1 u(i,j,l)=0. enddo enddo @@ -87,7 +88,7 @@ SUBROUTINE ALLOCATE_ALL() !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jvend_2u - do i=1,im + do i=ista_2l,iend_2u v(i,j,l)=0. enddo enddo @@ -95,7 +96,7 @@ SUBROUTINE ALLOCATE_ALL() !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u t(i,j,l)=spval q(i,j,l)=spval uh(i,j,l)=spval @@ -121,7 +122,7 @@ SUBROUTINE ALLOCATE_ALL() !$omp parallel do private(i,j,l) do l=1,lp1 do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u pint(i,j,l)=spval alpint(i,j,l)=spval zint(i,j,l)=spval @@ -130,38 +131,38 @@ SUBROUTINE ALLOCATE_ALL() enddo ! MP FIELD - allocate(cwm(im,jsta_2l:jend_2u,lm)) - allocate(F_ice(im,jsta_2l:jend_2u,lm)) - allocate(F_rain(im,jsta_2l:jend_2u,lm)) - allocate(F_RimeF(im,jsta_2l:jend_2u,lm)) - allocate(QQW(im,jsta_2l:jend_2u,lm)) - allocate(QRIMEF(im,jsta_2l:jend_2u,lm)) - allocate(QQI(im,jsta_2l:jend_2u,lm)) - allocate(QQR(im,jsta_2l:jend_2u,lm)) - allocate(QQS(im,jsta_2l:jend_2u,lm)) - allocate(QQG(im,jsta_2l:jend_2u,lm)) - allocate(QQNW(im,jsta_2l:jend_2u,lm)) - allocate(QQNI(im,jsta_2l:jend_2u,lm)) - allocate(QQNR(im,jsta_2l:jend_2u,lm)) - allocate(QQNWFA(im,jsta_2l:jend_2u,lm)) - allocate(QQNIFA(im,jsta_2l:jend_2u,lm)) - allocate(TAOD5503D(im,jsta_2l:jend_2u,lm)) - allocate(AEXTC55(im,jsta_2l:jend_2u,lm)) - allocate(EXTCOF55(im,jsta_2l:jend_2u,lm)) - allocate(QC_BL(im,jsta_2l:jend_2u,lm)) - allocate(CFR(im,jsta_2l:jend_2u,lm)) - allocate(CFR_RAW(im,jsta_2l:jend_2u,lm)) - allocate(DBZ(im,jsta_2l:jend_2u,lm)) - allocate(DBZR(im,jsta_2l:jend_2u,lm)) - allocate(DBZI(im,jsta_2l:jend_2u,lm)) - allocate(DBZC(im,jsta_2l:jend_2u,lm)) - allocate(mcvg(im,jsta_2l:jend_2u,lm)) - allocate(NLICE(im,jsta_2l:jend_2u,lm)) + allocate(cwm(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(F_ice(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(F_rain(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(F_RimeF(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQW(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QRIMEF(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQI(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQR(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQS(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQG(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQNW(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQNI(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQNR(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQNWFA(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QQNIFA(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(TAOD5503D(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(AEXTC55(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(EXTCOF55(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(QC_BL(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(CFR(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(CFR_RAW(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(DBZ(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(DBZR(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(DBZI(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(DBZC(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(mcvg(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(NLICE(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u cwm(i,j,l)=spval F_ice(i,j,l)=spval F_rain(i,j,l)=spval @@ -193,23 +194,23 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo ! Wm Lewis: added - allocate(NRAIN(im,jsta_2l:jend_2u,lm)) - allocate(radius_cloud(im,jsta_2l:jend_2u,lm)) - allocate(radius_ice(im,jsta_2l:jend_2u,lm)) - allocate(radius_snow(im,jsta_2l:jend_2u,lm)) + allocate(NRAIN(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(radius_cloud(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(radius_ice(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(radius_snow(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) ! KRS: HWRF Addition for thompson reflectivity ! or non-ferrier physics. wrf-derived - allocate(REFL_10CM(im,jsta_2l:jend_2u,lm)) + allocate(REFL_10CM(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !GFS FIELD - allocate(o3(im,jsta_2l:jend_2u,lm)) - allocate(o(im,jsta_2l:jend_2u,lm)) - allocate(o2(im,jsta_2l:jend_2u,lm)) - allocate(tcucns(im,jsta_2l:jend_2u,lm)) + allocate(o3(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(o(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(o2(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(tcucns(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u NRAIN(i,j,l)=spval radius_cloud(i,j,l)=spval radius_ice(i,j,l)=spval @@ -225,34 +226,34 @@ SUBROUTINE ALLOCATE_ALL() ! Add GFS d3d fields if (me == 0) print *,' d3d_on=',d3d_on if (d3d_on) then - allocate(vdifftt(im,jsta_2l:jend_2u,lm)) -! allocate(tcucns(im,jsta_2l:jend_2u,lm)) - allocate(vdiffmois(im,jsta_2l:jend_2u,lm)) - allocate(dconvmois(im,jsta_2l:jend_2u,lm)) - allocate(sconvmois(im,jsta_2l:jend_2u,lm)) - allocate(nradtt(im,jsta_2l:jend_2u,lm)) - allocate(o3vdiff(im,jsta_2l:jend_2u,lm)) - allocate(o3prod(im,jsta_2l:jend_2u,lm)) - allocate(o3tndy(im,jsta_2l:jend_2u,lm)) - allocate(mwpv(im,jsta_2l:jend_2u,lm)) - allocate(unknown(im,jsta_2l:jend_2u,lm)) - allocate(vdiffzacce(im,jsta_2l:jend_2u,lm)) - allocate(zgdrag(im,jsta_2l:jend_2u,lm)) - allocate(cnvctummixing(im,jsta_2l:jend_2u,lm)) - allocate(vdiffmacce(im,jsta_2l:jend_2u,lm)) - allocate(mgdrag(im,jsta_2l:jend_2u,lm)) - allocate(cnvctvmmixing(im,jsta_2l:jend_2u,lm)) - allocate(ncnvctcfrac(im,jsta_2l:jend_2u,lm)) - allocate(cnvctumflx(im,jsta_2l:jend_2u,lm)) - allocate(cnvctdmflx(im,jsta_2l:jend_2u,lm)) - allocate(cnvctdetmflx(im,jsta_2l:jend_2u,lm)) - allocate(cnvctzgdrag(im,jsta_2l:jend_2u,lm)) - allocate(cnvctmgdrag(im,jsta_2l:jend_2u,lm)) + allocate(vdifftt(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) +! allocate(tcucns(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(vdiffmois(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(dconvmois(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(sconvmois(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(nradtt(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(o3vdiff(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(o3prod(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(o3tndy(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(mwpv(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(unknown(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(vdiffzacce(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(zgdrag(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctummixing(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(vdiffmacce(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(mgdrag(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctvmmixing(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ncnvctcfrac(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctumflx(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctdmflx(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctdetmflx(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctzgdrag(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(cnvctmgdrag(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u vdifftt(i,j,l)=spval vdiffmois(i,j,l)=spval dconvmois(i,j,l)=spval @@ -280,21 +281,21 @@ SUBROUTINE ALLOCATE_ALL() enddo endif ! - allocate(htm(im,jsta_2l:jend_2u,lm)) - allocate(vtm(im,jsta_2l:jend_2u,lm)) + allocate(htm(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(vtm(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) ! add GFIP ICING - allocate(icing_gfip(im,jsta_2l:jend_2u,lm)) - allocate(icing_gfis(im,jsta_2l:jend_2u,lm)) + allocate(icing_gfip(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(icing_gfis(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) ! ! add GTG turbulence - allocate(catedr(im,jsta_2l:jend_2u,lm)) - allocate(mwt(im,jsta_2l:jend_2u,lm)) - allocate(gtg(im,jsta_2l:jend_2u,lm)) + allocate(catedr(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(mwt(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(gtg(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u htm(i,j,l)=spval vtm(i,j,l)=spval icing_gfip(i,j,l)=spval @@ -308,9 +309,9 @@ SUBROUTINE ALLOCATE_ALL() ! ! FROM SOIL ! - allocate(smc(im,jsta_2l:jend_2u,nsoil)) - allocate(stc(im,jsta_2l:jend_2u,nsoil)) - allocate(sh2o(im,jsta_2l:jend_2u,nsoil)) + allocate(smc(ista_2l:iend_2u,jsta_2l:jend_2u,nsoil)) + allocate(stc(ista_2l:iend_2u,jsta_2l:jend_2u,nsoil)) + allocate(sh2o(ista_2l:iend_2u,jsta_2l:jend_2u,nsoil)) allocate(SLDPTH(NSOIL)) allocate(RTDPTH(NSOIL)) allocate(SLLEVEL(NSOIL)) @@ -318,7 +319,7 @@ SUBROUTINE ALLOCATE_ALL() !$omp parallel do private(i,j,l) do l=1,nsoil do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u smc(i,j,l)=spval stc(i,j,l)=spval sh2o(i,j,l)=spval @@ -335,25 +336,25 @@ SUBROUTINE ALLOCATE_ALL() ! FROM VRBLS2D ! ! SRD - allocate(wspd10max(im,jsta_2l:jend_2u)) - allocate(w_up_max(im,jsta_2l:jend_2u)) - allocate(w_dn_max(im,jsta_2l:jend_2u)) - allocate(w_mean(im,jsta_2l:jend_2u)) - allocate(refd_max(im,jsta_2l:jend_2u)) - allocate(prate_max(im,jsta_2l:jend_2u)) - allocate(fprate_max(im,jsta_2l:jend_2u)) - allocate(up_heli_max(im,jsta_2l:jend_2u)) - allocate(up_heli_max16(im,jsta_2l:jend_2u)) - allocate(up_heli_min(im,jsta_2l:jend_2u)) - allocate(up_heli_min16(im,jsta_2l:jend_2u)) - allocate(up_heli_max02(im,jsta_2l:jend_2u)) - allocate(up_heli_min02(im,jsta_2l:jend_2u)) - allocate(up_heli_max03(im,jsta_2l:jend_2u)) - allocate(up_heli_min03(im,jsta_2l:jend_2u)) + allocate(wspd10max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(w_up_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(w_dn_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(w_mean(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(refd_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(prate_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(fprate_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_max16(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_min(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_min16(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_max02(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_min02(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_max03(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli_min03(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u wspd10max(i,j)=spval w_up_max(i,j)=spval w_dn_max(i,j)=spval @@ -371,31 +372,31 @@ SUBROUTINE ALLOCATE_ALL() up_heli_min03(i,j)=spval enddo enddo - allocate(rel_vort_max(im,jsta_2l:jend_2u)) - allocate(rel_vort_max01(im,jsta_2l:jend_2u)) - allocate(rel_vort_maxhy1(im,jsta_2l:jend_2u)) - allocate(wspd10umax(im,jsta_2l:jend_2u)) - allocate(wspd10vmax(im,jsta_2l:jend_2u)) - allocate(refdm10c_max(im,jsta_2l:jend_2u)) - allocate(hail_max2d(im,jsta_2l:jend_2u)) - allocate(hail_maxk1(im,jsta_2l:jend_2u)) - allocate(hail_maxhailcast(im,jsta_2l:jend_2u)) - allocate(grpl_max(im,jsta_2l:jend_2u)) - allocate(up_heli(im,jsta_2l:jend_2u)) - allocate(up_heli16(im,jsta_2l:jend_2u)) - allocate(ltg1_max(im,jsta_2l:jend_2u)) - allocate(ltg2_max(im,jsta_2l:jend_2u)) - allocate(ltg3_max(im,jsta_2l:jend_2u)) - allocate(nci_ltg(im,jsta_2l:jend_2u)) - allocate(nca_ltg(im,jsta_2l:jend_2u)) - allocate(nci_wq(im,jsta_2l:jend_2u)) - allocate(nca_wq(im,jsta_2l:jend_2u)) - allocate(nci_refd(im,jsta_2l:jend_2u)) - allocate(nca_refd(im,jsta_2l:jend_2u)) + allocate(rel_vort_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rel_vort_max01(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rel_vort_maxhy1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(wspd10umax(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(wspd10vmax(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(refdm10c_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(hail_max2d(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(hail_maxk1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(hail_maxhailcast(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(grpl_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(up_heli16(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ltg1_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ltg2_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ltg3_max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(nci_ltg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(nca_ltg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(nci_wq(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(nca_wq(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(nci_refd(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(nca_refd(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u rel_vort_max(i,j)=spval rel_vort_max01(i,j)=spval rel_vort_maxhy1(i,j)=spval @@ -421,60 +422,60 @@ SUBROUTINE ALLOCATE_ALL() enddo ! SRD ! CRA - allocate(REF_10CM(im,jsta_2l:jend_2u,lm)) + allocate(REF_10CM(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u REF_10CM(i,j,l)=spval enddo enddo enddo - allocate(REFC_10CM(im,jsta_2l:jend_2u)) - allocate(REF1KM_10CM(im,jsta_2l:jend_2u)) - allocate(REF4KM_10CM(im,jsta_2l:jend_2u)) + allocate(REFC_10CM(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(REF1KM_10CM(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(REF4KM_10CM(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u REFC_10CM(i,j)=spval REF1KM_10CM(i,j)=spval REF4KM_10CM(i,j)=spval enddo enddo ! CRA - allocate(u10(im,jsta_2l:jend_2u)) - allocate(v10(im,jsta_2l:jend_2u)) - allocate(tshltr(im,jsta_2l:jend_2u)) - allocate(qshltr(im,jsta_2l:jend_2u)) - allocate(mrshltr(im,jsta_2l:jend_2u)) - allocate(smstav(im,jsta_2l:jend_2u)) - allocate(ssroff(im,jsta_2l:jend_2u)) - allocate(bgroff(im,jsta_2l:jend_2u)) - allocate(vegfrc(im,jsta_2l:jend_2u)) - allocate(shdmin(im,jsta_2l:jend_2u)) - allocate(shdmax(im,jsta_2l:jend_2u)) - allocate(lai(im,jsta_2l:jend_2u)) - allocate(acsnow(im,jsta_2l:jend_2u)) - allocate(acgraup(im,jsta_2l:jend_2u)) - allocate(acfrain(im,jsta_2l:jend_2u)) - allocate(acsnom(im,jsta_2l:jend_2u)) - allocate(cmc(im,jsta_2l:jend_2u)) - allocate(sst(im,jsta_2l:jend_2u)) - allocate(qz0(im,jsta_2l:jend_2u)) - allocate(thz0(im,jsta_2l:jend_2u)) - allocate(uz0(im,jsta_2l:jend_2u)) - allocate(vz0(im,jsta_2l:jend_2u)) - allocate(qs(im,jsta_2l:jend_2u)) - allocate(ths(im,jsta_2l:jend_2u)) - allocate(sno(im,jsta_2l:jend_2u)) - allocate(snonc(im,jsta_2l:jend_2u)) - allocate(ti(im,jsta_2l:jend_2u)) + allocate(u10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(v10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(tshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mrshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(smstav(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ssroff(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bgroff(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(vegfrc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(shdmin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(shdmax(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(lai(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acsnow(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acgraup(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acfrain(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acsnom(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cmc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sst(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qz0(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(thz0(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(uz0(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(vz0(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qs(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ths(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sno(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snonc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ti(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u u10(i,j)=spval v10(i,j)=spval tshltr(i,j)=spval @@ -505,15 +506,15 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo ! Time-averaged fileds - allocate(u10mean(im,jsta_2l:jend_2u)) - allocate(v10mean(im,jsta_2l:jend_2u)) - allocate(spduv10mean(im,jsta_2l:jend_2u)) - allocate(swradmean(im,jsta_2l:jend_2u)) - allocate(swnormmean(im,jsta_2l:jend_2u)) + allocate(u10mean(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(v10mean(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(spduv10mean(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swradmean(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swnormmean(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u u10mean(i,j)=spval v10mean(i,j)=spval spduv10mean(i,j)=spval @@ -522,20 +523,20 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo !NAMstart - allocate(snoavg(im,jsta_2l:jend_2u)) - allocate(psfcavg(im,jsta_2l:jend_2u)) - allocate(t10m(im,jsta_2l:jend_2u)) - allocate(t10avg(im,jsta_2l:jend_2u)) - allocate(akmsavg(im,jsta_2l:jend_2u)) - allocate(akhsavg(im,jsta_2l:jend_2u)) - allocate(u10max(im,jsta_2l:jend_2u)) - allocate(v10max(im,jsta_2l:jend_2u)) - allocate(u10h(im,jsta_2l:jend_2u)) - allocate(v10h(im,jsta_2l:jend_2u)) + allocate(snoavg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(psfcavg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(t10m(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(t10avg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(akmsavg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(akhsavg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(u10max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(v10max(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(u10h(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(v10h(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u snoavg(i,j)=spval psfcavg(i,j)=spval t10m(i,j)=spval @@ -549,16 +550,16 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo !NAMend - allocate(akms(im,jsta_2l:jend_2u)) - allocate(akhs(im,jsta_2l:jend_2u)) - allocate(cuprec(im,jsta_2l:jend_2u)) - allocate(acprec(im,jsta_2l:jend_2u)) - allocate(ancprc(im,jsta_2l:jend_2u)) - allocate(cuppt(im,jsta_2l:jend_2u)) + allocate(akms(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(akhs(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cuprec(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acprec(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ancprc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cuppt(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u akms(i,j)=spval akhs(i,j)=spval cuprec(i,j)=spval @@ -568,33 +569,33 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo ! GSDstart - allocate(rainc_bucket(im,jsta_2l:jend_2u)) - allocate(rainc_bucket1(im,jsta_2l:jend_2u)) - allocate(rainnc_bucket(im,jsta_2l:jend_2u)) - allocate(rainnc_bucket1(im,jsta_2l:jend_2u)) - allocate(pcp_bucket(im,jsta_2l:jend_2u)) - allocate(pcp_bucket1(im,jsta_2l:jend_2u)) - allocate(snow_bucket(im,jsta_2l:jend_2u)) - allocate(snow_bucket1(im,jsta_2l:jend_2u)) - allocate(graup_bucket(im,jsta_2l:jend_2u)) - allocate(graup_bucket1(im,jsta_2l:jend_2u)) - allocate(qrmax(im,jsta_2l:jend_2u)) - allocate(tmax(im,jsta_2l:jend_2u)) - allocate(snownc(im,jsta_2l:jend_2u)) - allocate(graupelnc(im,jsta_2l:jend_2u)) - allocate(tsnow(im,jsta_2l:jend_2u)) - allocate(qvg(im,jsta_2l:jend_2u)) - allocate(qv2m(im,jsta_2l:jend_2u)) - allocate(qvl1(im,jsta_2l:jend_2u)) - allocate(snfden(im,jsta_2l:jend_2u)) - allocate(sndepac(im,jsta_2l:jend_2u)) - allocate(int_smoke(im,jsta_2l:jend_2u)) - allocate(mean_frp(im,jsta_2l:jend_2u)) - allocate(int_aod(im,jsta_2l:jend_2u)) + allocate(rainc_bucket(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rainc_bucket1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rainnc_bucket(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rainnc_bucket1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pcp_bucket(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pcp_bucket1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snow_bucket(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snow_bucket1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(graup_bucket(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(graup_bucket1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qrmax(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(tmax(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snownc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(graupelnc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(tsnow(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qvg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qv2m(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qvl1(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snfden(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sndepac(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(int_smoke(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mean_frp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(int_aod(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u rainc_bucket(i,j)=spval rainc_bucket1(i,j)=spval rainnc_bucket(i,j)=spval @@ -620,40 +621,40 @@ SUBROUTINE ALLOCATE_ALL() int_aod(i,j)=spval enddo enddo - allocate(smoke(im,jsta_2l:jend_2u,lm,nbin_sm)) + allocate(smoke(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_sm)) !$omp parallel do private(i,j,l,k) do k=1,nbin_sm do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u smoke(i,j,l,k)=spval enddo enddo enddo enddo ! GSDend - allocate(rswin(im,jsta_2l:jend_2u)) - allocate(swddni(im,jsta_2l:jend_2u)) - allocate(swddif(im,jsta_2l:jend_2u)) - allocate(swdnbc(im,jsta_2l:jend_2u)) - allocate(swddnic(im,jsta_2l:jend_2u)) - allocate(swddifc(im,jsta_2l:jend_2u)) - allocate(swupbc(im,jsta_2l:jend_2u)) - allocate(swupt(im,jsta_2l:jend_2u)) - allocate(taod5502d(im,jsta_2l:jend_2u)) - allocate(aerasy2d(im,jsta_2l:jend_2u)) - allocate(aerssa2d(im,jsta_2l:jend_2u)) - allocate(lwp(im,jsta_2l:jend_2u)) - allocate(iwp(im,jsta_2l:jend_2u)) - allocate(rlwin(im,jsta_2l:jend_2u)) - allocate(lwdnbc(im,jsta_2l:jend_2u)) - allocate(lwupbc(im,jsta_2l:jend_2u)) - allocate(rlwtoa(im,jsta_2l:jend_2u)) - allocate(rswtoa(im,jsta_2l:jend_2u)) + allocate(rswin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swddni(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swddif(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swdnbc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swddnic(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swddifc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swupbc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swupt(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(taod5502d(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aerasy2d(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aerssa2d(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(lwp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(iwp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rlwin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(lwdnbc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(lwupbc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rlwtoa(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rswtoa(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u rswin(i,j)=spval swddni(i,j)=spval swddif(i,j)=spval @@ -674,33 +675,33 @@ SUBROUTINE ALLOCATE_ALL() rswtoa(i,j)=spval enddo enddo - allocate(tg(im,jsta_2l:jend_2u)) - allocate(sfcshx(im,jsta_2l:jend_2u)) - allocate(sfclhx(im,jsta_2l:jend_2u)) - allocate(fis(im,jsta_2l:jend_2u)) - allocate(t500(im,jsta_2l:jend_2u)) - allocate(t700(im,jsta_2l:jend_2u)) - allocate(z500(im,jsta_2l:jend_2u)) - allocate(z700(im,jsta_2l:jend_2u)) - allocate(teql(im,jsta_2l:jend_2u)) - allocate(ieql(im,jsta_2l:jend_2u)) - allocate(cfracl(im,jsta_2l:jend_2u)) - allocate(cfracm(im,jsta_2l:jend_2u)) - allocate(cfrach(im,jsta_2l:jend_2u)) - allocate(acfrst(im,jsta_2l:jend_2u)) - allocate(acfrcv(im,jsta_2l:jend_2u)) - allocate(hbot(im,jsta_2l:jend_2u)) - allocate(htop(im,jsta_2l:jend_2u)) - allocate(aswin(im,jsta_2l:jend_2u)) - allocate(alwin(im,jsta_2l:jend_2u)) - allocate(aswout(im,jsta_2l:jend_2u)) - allocate(alwout(im,jsta_2l:jend_2u)) - allocate(aswtoa(im,jsta_2l:jend_2u)) - allocate(alwtoa(im,jsta_2l:jend_2u)) + allocate(tg(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcshx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfclhx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(fis(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(t500(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(t700(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(z500(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(z700(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(teql(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ieql(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cfracl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cfracm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cfrach(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acfrst(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acfrcv(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(hbot(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(htop(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(alwin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswout(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(alwout(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswtoa(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(alwtoa(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u tg(i,j)=spval sfcshx(i,j)=spval sfclhx(i,j)=spval @@ -725,36 +726,36 @@ SUBROUTINE ALLOCATE_ALL() alwtoa(i,j)=spval enddo enddo - allocate(czen(im,jsta_2l:jend_2u)) - allocate(czmean(im,jsta_2l:jend_2u)) - allocate(sigt4(im,jsta_2l:jend_2u)) - allocate(rswout(im,jsta_2l:jend_2u)) - allocate(radot(im,jsta_2l:jend_2u)) - allocate(ncfrst(im,jsta_2l:jend_2u)) ! real - allocate(ncfrcv(im,jsta_2l:jend_2u)) ! real - allocate(smstot(im,jsta_2l:jend_2u)) - allocate(pctsno(im,jsta_2l:jend_2u)) - allocate(pshltr(im,jsta_2l:jend_2u)) - allocate(th10(im,jsta_2l:jend_2u)) - allocate(q10(im,jsta_2l:jend_2u)) - allocate(sr(im,jsta_2l:jend_2u)) - allocate(prec(im,jsta_2l:jend_2u)) - allocate(subshx(im,jsta_2l:jend_2u)) - allocate(snopcx(im,jsta_2l:jend_2u)) - allocate(sfcuvx(im,jsta_2l:jend_2u)) - allocate(sfcevp(im,jsta_2l:jend_2u)) - allocate(potevp(im,jsta_2l:jend_2u)) - allocate(z0(im,jsta_2l:jend_2u)) - allocate(ustar(im,jsta_2l:jend_2u)) - allocate(pblh(im,jsta_2l:jend_2u)) - allocate(pblhgust(im,jsta_2l:jend_2u)) - allocate(mixht(im,jsta_2l:jend_2u)) - allocate(twbs(im,jsta_2l:jend_2u)) - allocate(qwbs(im,jsta_2l:jend_2u)) + allocate(czen(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(czmean(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sigt4(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rswout(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(radot(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ncfrst(ista_2l:iend_2u,jsta_2l:jend_2u)) ! real + allocate(ncfrcv(ista_2l:iend_2u,jsta_2l:jend_2u)) ! real + allocate(smstot(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pctsno(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(th10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(q10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(prec(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(subshx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snopcx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcuvx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcevp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(potevp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(z0(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ustar(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pblh(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pblhgust(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mixht(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(twbs(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(qwbs(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u czen(i,j)=spval czmean(i,j)=spval sigt4(i,j)=spval @@ -783,37 +784,37 @@ SUBROUTINE ALLOCATE_ALL() qwbs(i,j)=spval enddo enddo - allocate(sfcexc(im,jsta_2l:jend_2u)) - allocate(grnflx(im,jsta_2l:jend_2u)) - allocate(soiltb(im,jsta_2l:jend_2u)) - allocate(z1000(im,jsta_2l:jend_2u)) - allocate(slp(im,jsta_2l:jend_2u)) - allocate(pslp(im,jsta_2l:jend_2u)) - allocate(f(im,jsta_2l:jend_2u)) - allocate(albedo(im,jsta_2l:jend_2u)) - allocate(albase(im,jsta_2l:jend_2u)) - allocate(cldfra(im,jsta_2l:jend_2u)) - allocate(cprate(im,jsta_2l:jend_2u)) - allocate(cnvcfr(im,jsta_2l:jend_2u)) - allocate(ivgtyp(im,jsta_2l:jend_2u)) - allocate(isltyp(im,jsta_2l:jend_2u)) - allocate(hbotd(im,jsta_2l:jend_2u)) - allocate(htopd(im,jsta_2l:jend_2u)) - allocate(hbots(im,jsta_2l:jend_2u)) - allocate(htops(im,jsta_2l:jend_2u)) - allocate(cldefi(im,jsta_2l:jend_2u)) - allocate(islope(im,jsta_2l:jend_2u)) - allocate(si(im,jsta_2l:jend_2u)) - allocate(lspa(im,jsta_2l:jend_2u)) - allocate(rswinc(im,jsta_2l:jend_2u)) - allocate(vis(im,jsta_2l:jend_2u)) - allocate(pd(im,jsta_2l:jend_2u)) - allocate(mxsnal(im,jsta_2l:jend_2u)) - allocate(epsr(im,jsta_2l:jend_2u)) + allocate(sfcexc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(grnflx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(soiltb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(z1000(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(slp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pslp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(f(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(albedo(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(albase(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cldfra(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cprate(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cnvcfr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ivgtyp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(isltyp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(hbotd(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(htopd(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(hbots(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(htops(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cldefi(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(islope(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(si(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(lspa(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rswinc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(vis(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pd(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mxsnal(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(epsr(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u sfcexc(i,j)=spval grnflx(i,j)=spval soiltb(i,j)=spval @@ -844,47 +845,47 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo ! add GFS fields - allocate(sfcux(im,jsta_2l:jend_2u)) - allocate(sfcvx(im,jsta_2l:jend_2u)) - allocate(sfcuxi(im,jsta_2l:jend_2u)) - allocate(sfcvxi(im,jsta_2l:jend_2u)) - allocate(avgalbedo(im,jsta_2l:jend_2u)) - allocate(avgcprate(im,jsta_2l:jend_2u)) - allocate(avgprec(im,jsta_2l:jend_2u)) - allocate(avgprec_cont(im,jsta_2l:jend_2u)) - allocate(avgcprate_cont(im,jsta_2l:jend_2u)) - allocate(ptop(im,jsta_2l:jend_2u)) - allocate(pbot(im,jsta_2l:jend_2u)) - allocate(avgcfrach(im,jsta_2l:jend_2u)) - allocate(avgcfracm(im,jsta_2l:jend_2u)) - allocate(avgcfracl(im,jsta_2l:jend_2u)) - allocate(avgtcdc(im,jsta_2l:jend_2u)) - allocate(auvbin(im,jsta_2l:jend_2u)) - allocate(auvbinc(im,jsta_2l:jend_2u)) - allocate(ptopl(im,jsta_2l:jend_2u)) - allocate(pbotl(im,jsta_2l:jend_2u)) - allocate(Ttopl(im,jsta_2l:jend_2u)) - allocate(ptopm(im,jsta_2l:jend_2u)) - allocate(pbotm(im,jsta_2l:jend_2u)) - allocate(Ttopm(im,jsta_2l:jend_2u)) - allocate(ptoph(im,jsta_2l:jend_2u)) - allocate(pboth(im,jsta_2l:jend_2u)) - allocate(Ttoph(im,jsta_2l:jend_2u)) - allocate(sfcugs(im,jsta_2l:jend_2u)) - allocate(sfcvgs(im,jsta_2l:jend_2u)) - allocate(pblcfr(im,jsta_2l:jend_2u)) - allocate(cldwork(im,jsta_2l:jend_2u)) - allocate(gtaux(im,jsta_2l:jend_2u)) - allocate(gtauy(im,jsta_2l:jend_2u)) - allocate(cd10(im,jsta_2l:jend_2u)) - allocate(ch10(im,jsta_2l:jend_2u)) - allocate(mdltaux(im,jsta_2l:jend_2u)) - allocate(mdltauy(im,jsta_2l:jend_2u)) - allocate(runoff(im,jsta_2l:jend_2u)) + allocate(sfcux(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcvx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcuxi(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcvxi(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgalbedo(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgcprate(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgprec(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgprec_cont(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgcprate_cont(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ptop(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pbot(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgcfrach(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgcfracm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgcfracl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgtcdc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(auvbin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(auvbinc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ptopl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pbotl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(Ttopl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ptopm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pbotm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(Ttopm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ptoph(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pboth(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(Ttoph(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcugs(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sfcvgs(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pblcfr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cldwork(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(gtaux(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(gtauy(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(cd10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ch10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mdltaux(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mdltauy(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(runoff(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u sfcux(i,j)=spval sfcvx(i,j)=spval sfcuxi(i,j)=spval @@ -924,56 +925,57 @@ SUBROUTINE ALLOCATE_ALL() runoff(i,j)=spval enddo enddo - allocate(maxtshltr(im,jsta_2l:jend_2u)) - allocate(mintshltr(im,jsta_2l:jend_2u)) - allocate(maxrhshltr(im,jsta_2l:jend_2u)) - allocate(minrhshltr(im,jsta_2l:jend_2u)) - allocate(maxqshltr(im,jsta_2l:jend_2u)) - allocate(minqshltr(im,jsta_2l:jend_2u)) - allocate(dzice(im,jsta_2l:jend_2u)) - allocate(alwinc(im,jsta_2l:jend_2u)) - allocate(alwoutc(im,jsta_2l:jend_2u)) - allocate(alwtoac(im,jsta_2l:jend_2u)) - allocate(aswinc(im,jsta_2l:jend_2u)) - allocate(aswoutc(im,jsta_2l:jend_2u)) - allocate(aswtoac(im,jsta_2l:jend_2u)) - allocate(aswintoa(im,jsta_2l:jend_2u)) - allocate(smcwlt(im,jsta_2l:jend_2u)) - allocate(suntime(im,jsta_2l:jend_2u)) - allocate(fieldcapa(im,jsta_2l:jend_2u)) - allocate(avisbeamswin(im,jsta_2l:jend_2u)) - allocate(avisdiffswin(im,jsta_2l:jend_2u)) - allocate(airbeamswin(im,jsta_2l:jend_2u)) - allocate(airdiffswin(im,jsta_2l:jend_2u)) - allocate(snowfall(im,jsta_2l:jend_2u)) - allocate(acond(im,jsta_2l:jend_2u)) - allocate(edir(im,jsta_2l:jend_2u)) - allocate(ecan(im,jsta_2l:jend_2u)) - allocate(etrans(im,jsta_2l:jend_2u)) - allocate(esnow(im,jsta_2l:jend_2u)) - allocate(avgedir(im,jsta_2l:jend_2u)) - allocate(avgecan(im,jsta_2l:jend_2u)) - allocate(avgetrans(im,jsta_2l:jend_2u)) - allocate(avgesnow(im,jsta_2l:jend_2u)) - allocate(avgpotevp(im,jsta_2l:jend_2u)) - allocate(aod550(im,jsta_2l:jend_2u)) - allocate(du_aod550(im,jsta_2l:jend_2u)) - allocate(ss_aod550(im,jsta_2l:jend_2u)) - allocate(su_aod550(im,jsta_2l:jend_2u)) - allocate(oc_aod550(im,jsta_2l:jend_2u)) - allocate(bc_aod550(im,jsta_2l:jend_2u)) - allocate(landfrac(im,jsta_2l:jend_2u)) - allocate(paha(im,jsta_2l:jend_2u)) - allocate(pahi(im,jsta_2l:jend_2u)) - allocate(tecan(im,jsta_2l:jend_2u)) - allocate(tetran(im,jsta_2l:jend_2u)) - allocate(tedir(im,jsta_2l:jend_2u)) - allocate(twa(im,jsta_2l:jend_2u)) - allocate(fdnsst(im,jsta_2l:jend_2u)) + allocate(maxtshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(mintshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(maxrhshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(minrhshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(maxqshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(minqshltr(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dzice(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(alwinc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(alwoutc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(alwtoac(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswinc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswoutc(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswtoac(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aswintoa(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(smcwlt(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(suntime(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(fieldcapa(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avisbeamswin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avisdiffswin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(airbeamswin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(airdiffswin(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(snowfall(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acond(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(edir(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ecan(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(etrans(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(esnow(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgedir(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgecan(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgetrans(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgesnow(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(avgpotevp(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(aod550(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(du_aod550(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ss_aod550(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(su_aod550(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(oc_aod550(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bc_aod550(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(landfrac(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(paha(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pahi(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(tecan(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(tetran(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(tedir(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(twa(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(fdnsst(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pwat(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u maxtshltr(i,j)=spval mintshltr(i,j)=spval maxrhshltr(i,j)=spval @@ -1020,24 +1022,25 @@ SUBROUTINE ALLOCATE_ALL() tedir(i,j)=spval twa(i,j)=spval fdnsst(i,j)=spval + pwat(i,j)=spval enddo enddo ! ! FROM MASKS ! - allocate(hbm2(im,jsta_2l:jend_2u)) - allocate(sm(im,jsta_2l:jend_2u)) - allocate(sice(im,jsta_2l:jend_2u)) - allocate(lmh(im,jsta_2l:jend_2u)) ! real - allocate(lmv(im,jsta_2l:jend_2u)) ! real - allocate(gdlat(im,jsta_2l:jend_2u)) - allocate(gdlon(im,jsta_2l:jend_2u)) - allocate(dx(im,jsta_2l:jend_2u)) - allocate(dy(im,jsta_2l:jend_2u)) + allocate(hbm2(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sice(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(lmh(ista_2l:iend_2u,jsta_2l:jend_2u)) ! real + allocate(lmv(ista_2l:iend_2u,jsta_2l:jend_2u)) ! real + allocate(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(gdlon(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dy(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u hbm2(i,j)=spval sm(i,j)=spval sice(i,j)=spval @@ -1055,19 +1058,19 @@ SUBROUTINE ALLOCATE_ALL() ! ! Add GOCART fields ! vrbls4d - allocate(dust(im,jsta_2l:jend_2u,lm,nbin_du)) - allocate(salt(im,jsta_2l:jend_2u,lm,nbin_ss)) - allocate(soot(im,jsta_2l:jend_2u,lm,nbin_bc)) - allocate(waso(im,jsta_2l:jend_2u,lm,nbin_oc)) - allocate(suso(im,jsta_2l:jend_2u,lm,nbin_su)) - allocate(pp25(im,jsta_2l:jend_2u,lm,nbin_su)) - allocate(pp10(im,jsta_2l:jend_2u,lm,nbin_su)) + allocate(dust(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_du)) + allocate(salt(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_ss)) + allocate(soot(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_bc)) + allocate(waso(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_oc)) + allocate(suso(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_su)) + allocate(pp25(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_su)) + allocate(pp10(ista_2l:iend_2u,jsta_2l:jend_2u,lm,nbin_su)) !Initialization !$omp parallel do private(i,j,l,k) do k=1,nbin_du do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u dust(i,j,l,k)=spval enddo enddo @@ -1077,7 +1080,7 @@ SUBROUTINE ALLOCATE_ALL() do k=1,nbin_ss do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u salt(i,j,l,k)=spval enddo enddo @@ -1087,7 +1090,7 @@ SUBROUTINE ALLOCATE_ALL() do k=1,nbin_bc do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u soot(i,j,l,k)=spval enddo enddo @@ -1097,7 +1100,7 @@ SUBROUTINE ALLOCATE_ALL() do k=1,nbin_oc do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u waso(i,j,l,k)=spval enddo enddo @@ -1107,7 +1110,7 @@ SUBROUTINE ALLOCATE_ALL() do k=1,nbin_su do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u suso(i,j,l,k)=spval pp25(i,j,l,k)=spval pp10(i,j,l,k)=spval @@ -1116,15 +1119,15 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo ! vrbls3d - allocate(ext(im,jsta_2l:jend_2u,lm)) - allocate(asy(im,jsta_2l:jend_2u,lm)) - allocate(ssa(im,jsta_2l:jend_2u,lm)) - allocate(sca(im,jsta_2l:jend_2u,lm)) + allocate(ext(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asy(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ssa(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(sca(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u ext(i,j,l)=spval asy(i,j,l)=spval ssa(i,j,l)=spval @@ -1132,35 +1135,35 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo enddo - allocate(duem(im,jsta_2l:jend_2u,nbin_du)) - allocate(dusd(im,jsta_2l:jend_2u,nbin_du)) - allocate(dudp(im,jsta_2l:jend_2u,nbin_du)) - allocate(duwt(im,jsta_2l:jend_2u,nbin_du)) - allocate(dusv(im,jsta_2l:jend_2u,nbin_du)) - allocate(suem(im,jsta_2l:jend_2u,nbin_su)) - allocate(susd(im,jsta_2l:jend_2u,nbin_su)) - allocate(sudp(im,jsta_2l:jend_2u,nbin_su)) - allocate(suwt(im,jsta_2l:jend_2u,nbin_su)) - allocate(ocem(im,jsta_2l:jend_2u,nbin_oc)) - allocate(ocsd(im,jsta_2l:jend_2u,nbin_oc)) - allocate(ocdp(im,jsta_2l:jend_2u,nbin_oc)) - allocate(ocwt(im,jsta_2l:jend_2u,nbin_oc)) - allocate(ocsv(im,jsta_2l:jend_2u,nbin_oc)) - allocate(bcem(im,jsta_2l:jend_2u,nbin_bc)) - allocate(bcsd(im,jsta_2l:jend_2u,nbin_bc)) - allocate(bcdp(im,jsta_2l:jend_2u,nbin_bc)) - allocate(bcwt(im,jsta_2l:jend_2u,nbin_bc)) - allocate(bcsv(im,jsta_2l:jend_2u,nbin_bc)) - allocate(ssem(im,jsta_2l:jend_2u,nbin_ss)) - allocate(sssd(im,jsta_2l:jend_2u,nbin_ss)) - allocate(ssdp(im,jsta_2l:jend_2u,nbin_ss)) - allocate(sswt(im,jsta_2l:jend_2u,nbin_ss)) - allocate(sssv(im,jsta_2l:jend_2u,nbin_ss)) + allocate(duem(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_du)) + allocate(dusd(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_du)) + allocate(dudp(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_du)) + allocate(duwt(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_du)) + allocate(dusv(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_du)) + allocate(suem(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_su)) + allocate(susd(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_su)) + allocate(sudp(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_su)) + allocate(suwt(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_su)) + allocate(ocem(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_oc)) + allocate(ocsd(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_oc)) + allocate(ocdp(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_oc)) + allocate(ocwt(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_oc)) + allocate(ocsv(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_oc)) + allocate(bcem(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_bc)) + allocate(bcsd(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_bc)) + allocate(bcdp(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_bc)) + allocate(bcwt(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_bc)) + allocate(bcsv(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_bc)) + allocate(ssem(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_ss)) + allocate(sssd(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_ss)) + allocate(ssdp(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_ss)) + allocate(sswt(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_ss)) + allocate(sssv(ista_2l:iend_2u,jsta_2l:jend_2u,nbin_ss)) !Initialization !$omp parallel do private(i,j,l) do l=1,nbin_du do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u duem(i,j,l)=spval dusd(i,j,l)=spval dudp(i,j,l)=spval @@ -1172,7 +1175,7 @@ SUBROUTINE ALLOCATE_ALL() do l=1,nbin_su do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u suem(i,j,l)=spval susd(i,j,l)=spval sudp(i,j,l)=spval @@ -1183,7 +1186,7 @@ SUBROUTINE ALLOCATE_ALL() do l=1,nbin_oc do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u ocem(i,j,l)=spval ocsd(i,j,l)=spval ocdp(i,j,l)=spval @@ -1195,7 +1198,7 @@ SUBROUTINE ALLOCATE_ALL() do l=1,nbin_bc do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u bcem(i,j,l)=spval bcsd(i,j,l)=spval bcdp(i,j,l)=spval @@ -1207,7 +1210,7 @@ SUBROUTINE ALLOCATE_ALL() do l=1,nbin_ss do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u ssem(i,j,l)=spval sssd(i,j,l)=spval ssdp(i,j,l)=spval @@ -1216,52 +1219,54 @@ SUBROUTINE ALLOCATE_ALL() enddo enddo enddo - allocate(rhomid(im,jsta_2l:jend_2u,lm)) + allocate(rhomid(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u rhomid(i,j,l)=spval enddo enddo enddo ! vrbls2d - allocate(dusmass(im,jsta_2l:jend_2u)) - allocate(ducmass(im,jsta_2l:jend_2u)) - allocate(dusmass25(im,jsta_2l:jend_2u)) - allocate(ducmass25(im,jsta_2l:jend_2u)) - allocate(susmass(im,jsta_2l:jend_2u)) - allocate(sucmass(im,jsta_2l:jend_2u)) - allocate(susmass25(im,jsta_2l:jend_2u)) - allocate(sucmass25(im,jsta_2l:jend_2u)) - allocate(ocsmass(im,jsta_2l:jend_2u)) - allocate(occmass(im,jsta_2l:jend_2u)) - allocate(ocsmass25(im,jsta_2l:jend_2u)) - allocate(occmass25(im,jsta_2l:jend_2u)) - allocate(bcsmass(im,jsta_2l:jend_2u)) - allocate(bccmass(im,jsta_2l:jend_2u)) - allocate(bcsmass25(im,jsta_2l:jend_2u)) - allocate(bccmass25(im,jsta_2l:jend_2u)) - allocate(sssmass(im,jsta_2l:jend_2u)) - allocate(sscmass(im,jsta_2l:jend_2u)) - allocate(sssmass25(im,jsta_2l:jend_2u)) - allocate(sscmass25(im,jsta_2l:jend_2u)) - allocate(dustcb(im,jsta_2l:jend_2u)) - allocate(occb(im,jsta_2l:jend_2u)) - allocate(bccb(im,jsta_2l:jend_2u)) - allocate(sulfcb(im,jsta_2l:jend_2u)) - allocate(pp25cb(im,jsta_2l:jend_2u)) - allocate(pp10cb(im,jsta_2l:jend_2u)) - allocate(sscb(im,jsta_2l:jend_2u)) - allocate(dustallcb(im,jsta_2l:jend_2u)) - allocate(ssallcb(im,jsta_2l:jend_2u)) - allocate(dustpm(im,jsta_2l:jend_2u)) - allocate(sspm(im,jsta_2l:jend_2u)) + allocate(dusmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ducmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dusmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ducmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(susmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sucmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(susmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sucmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ocsmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(occmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ocsmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(occmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bcsmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bccmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bcsmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bccmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sssmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sscmass(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sssmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sscmass25(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(occb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(bccb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sulfcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pp25cb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(pp10cb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sscb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustallcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ssallcb(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustpm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(dustpm10(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(sspm(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(maod(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u dusmass(i,j)=spval ducmass(i,j)=spval dusmass25(i,j)=spval @@ -1292,18 +1297,20 @@ SUBROUTINE ALLOCATE_ALL() dustallcb(i,j)=spval ssallcb(i,j)=spval dustpm(i,j)=spval + dustpm10(i,j)=spval sspm(i,j)=spval + maod(i,j)=spval enddo enddo endif ! HWRF RRTMG output - allocate(acswupt(im,jsta_2l:jend_2u)) - allocate(swdnt(im,jsta_2l:jend_2u)) - allocate(acswdnt(im,jsta_2l:jend_2u)) + allocate(acswupt(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(swdnt(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(acswdnt(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u acswupt(i,j)=spval swdnt(i,j)=spval acswdnt(i,j)=spval @@ -1311,13 +1318,13 @@ SUBROUTINE ALLOCATE_ALL() enddo ! UPP_MATH MODULE DIFFERENTIAL EQUATIONS - allocate(ddvdx(im,jsta_2l:jend_2u)) - allocate(ddudy(im,jsta_2l:jend_2u)) - allocate(uuavg(im,jsta_2l:jend_2u)) + allocate(ddvdx(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ddudy(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(uuavg(ista_2l:iend_2u,jsta_2l:jend_2u)) !Initialization !$omp parallel do private(i,j) do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u ddvdx(i,j)=spval ddudy(i,j)=spval uuavg(i,j)=spval @@ -1328,14 +1335,14 @@ SUBROUTINE ALLOCATE_ALL() if (me == 0) print *,'aqfcmaq_on= ', aqfcmaq_on if (aqfcmaq_on) then - allocate(ozcon(im,jsta_2l:jend_2u,lm)) - allocate(pmtf(im,jsta_2l:jend_2u,lm)) + allocate(ozcon(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pmtf(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) !Initialization !$omp parallel do private(i,j,l) do l=1,lm do j=jsta_2l,jend_2u - do i=1,im + do i=ista_2l,iend_2u ozcon(i,j,l)=0. pmtf(i,j,l)=0. enddo diff --git a/sorc/ncep_post.fd/AVIATION.f b/sorc/ncep_post.fd/AVIATION.f index fe22243ec..010e5c8bd 100644 --- a/sorc/ncep_post.fd/AVIATION.f +++ b/sorc/ncep_post.fd/AVIATION.f @@ -67,7 +67,7 @@ SUBROUTINE CALLLWS(U,V,H,LLWS) ! USE vrbls2d, only: fis, u10, v10 use params_mod, only: gi - use ctlblk_mod, only: jsta, jend, im, jm, lsm, spval + use ctlblk_mod, only: jsta, jend, im, jm, lsm, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -84,7 +84,7 @@ SUBROUTINE CALLLWS(U,V,H,LLWS) ! DO 100 J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Z1 = 10.0 + FIS(I,J)*GI !Height of 10m levels geographic height (from sea level) @@ -158,20 +158,65 @@ SUBROUTINE CALLLWS(U,V,H,LLWS) !> !> @author Binbin Zhou NCEP/EMC @date 2005-08-16 SUBROUTINE CALICING (T1,RH,OMGA, ICING) - use ctlblk_mod, only: jsta, jend, im, spval +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: CALICING COMPUTES In-Flight Icing +! PRGRMMR: Binbin Zhou /NCEP/EMC DATE: 2005-08-16 +! +! ABSTRACT: +! This program computes the in-flight icing condition +! with the T-RH-OMGA algorithm provided by S. Silberberg of +! NCEP/AWC (improved new version) +! +! According to S. Silberberg, Icing happens in following +! situation: +! (1) -22C < T < 0C to +! (2) RH > 70 % +! (3) Ascent air, OMGA < 0 +! (4) Equivalent Potential Vorticity (EPV) < 0 +! (5) Cloud water if SLD (supercooled large droplet) +! +! Current version dosn't consider SLD, so cloud water +! is not used. EPV computation is not available for current +! NCEP/EMC models(NAM, WRF, RSM), so EPV is also not +! used +! +! USAGE: CALL CALICING(T1,RH,OMGA,ICING) +! INPUT ARGUMENT LIST: +! T1 - TEMPERATURE (K) +! RH - RELATIVE HUMIDITY (DECIMAL FORM) +! OMGA - Vertical velocity (Pa/sec) +! +! OUTPUT ARGUMENT LIST: +! ICING - ICING CONDITION (1 or 0) +! +! OUTPUT FILES: +! NONE +! +! SUBPROGRAMS CALLED: +! UTILITIES: +! LIBRARY: +! NONE +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90/77 +! MACHINE : BLUE AT NCEP +!$$$ +! + use ctlblk_mod, only: jsta, jend, im, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL, DIMENSION(IM,jsta:jend), INTENT(IN) :: T1,RH,OMGA - REAL, DIMENSION(IM,jsta:jend), INTENT(INOUT) :: ICING + REAL, DIMENSION(ista:iend,jsta:jend), INTENT(IN) :: T1,RH,OMGA + REAL, DIMENSION(ista:iend,jsta:jend), INTENT(INOUT) :: ICING integer I,J !*************************************************************** ! ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(OMGA(I,J)= 251.0) & @@ -219,7 +264,7 @@ SUBROUTINE CALICING (T1,RH,OMGA, ICING) SUBROUTINE CALCAT(U,V,H,U_OLD,V_OLD,H_OLD,CAT) use masks, only: dx, dy use ctlblk_mod, only: spval, jsta_2l, jend_2u, jsta_m, jend_m, & - im, jm + im, jm, ista_2l, iend_2u, ista_m, iend_m, ista, iend use gridspec_mod, only: gridtype ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -228,10 +273,10 @@ SUBROUTINE CALCAT(U,V,H,U_OLD,V_OLD,H_OLD,CAT) ! ! DECLARE VARIABLES. ! - REAL,DIMENSION(IM,jsta_2l:jend_2u),INTENT(IN) :: U,V,H, & + REAL,DIMENSION(ista_2l:iend_2u,jsta_2l:jend_2u),INTENT(IN) :: U,V,H, & U_OLD,V_OLD,H_OLD ! INTEGER,INTENT(IN) :: L - REAL,DIMENSION(IM,jsta_2l:jend_2u),INTENT(INOUT) :: CAT + REAL,DIMENSION(ista_2l:iend_2u,jsta_2l:jend_2u),INTENT(INOUT) :: CAT REAL DSH, DST, DEF, CVG, VWS, TRBINDX INTEGER IHE(JM),IHW(JM) @@ -247,22 +292,22 @@ SUBROUTINE CALCAT(U,V,H,U_OLD,V_OLD,H_OLD,CAT) IF(GRIDTYPE == 'A')THEN IHW(J)=-1 IHE(J)=1 - ISTART=2 - ISTOP=IM-1 + ISTART=ISTA_M + ISTOP=IEND_M JSTART=JSTA_M JSTOP=JEND_M ELSE IF(GRIDTYPE=='E')THEN IHW(J)=-MOD(J,2) IHE(J)=IHW(J)+1 - ISTART=2 - ISTOP=IM-1 + ISTART=ISTA_M + ISTOP=IEND_M JSTART=JSTA_M JSTOP=JEND_M ELSE IF(GRIDTYPE=='B')THEN IHW(J)=-1 IHE(J)=0 - ISTART=2 - ISTOP=IM-1 + ISTART=ISTA_M + ISTOP=IEND_M JSTART=JSTA_M JSTOP=JEND_M ELSE @@ -271,12 +316,12 @@ SUBROUTINE CALCAT(U,V,H,U_OLD,V_OLD,H_OLD,CAT) END IF ENDDO - call exch_f(U) - call exch_f(V) - call exch_f(U_OLD) - call exch_f(V_OLD) - call exch_f(H) - call exch_f(H_OLD) + call exch(U) + call exch(V) + call exch(U_OLD) + call exch(V_OLD) + call exch(H) + call exch(H_OLD) DO 100 J=JSTART,JSTOP DO I=ISTART,ISTOP @@ -451,20 +496,20 @@ SUBROUTINE CALCAT(U,V,H,U_OLD,V_OLD,H_OLD,CAT) SUBROUTINE CALCEILING (CLDZ,TCLD,CEILING) USE vrbls2d, only: fis use params_mod, only: small, gi - use ctlblk_mod, only: jsta, jend, spval, im, modelname + use ctlblk_mod, only: jsta, jend, spval, im, modelname, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL, DIMENSION(IM,jsta:jend), INTENT(IN) :: CLDZ, TCLD - REAL, DIMENSION(IM,jsta:jend), INTENT(INOUT) :: CEILING + REAL, DIMENSION(ista:iend,jsta:jend), INTENT(IN) :: CLDZ, TCLD + REAL, DIMENSION(ista:iend,jsta:jend), INTENT(INOUT) :: CEILING integer I,J !*************************************************************** ! ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(TCLD(I,J)-SPVAL) <= SMALL) THEN CEILING(I,J)=SPVAL ELSE IF(TCLD(I,J) >= 50.) THEN @@ -504,14 +549,14 @@ SUBROUTINE CALCEILING (CLDZ,TCLD,CEILING) !> @author Binbin Zhou NCEP/EMC @date 2005-08-18 SUBROUTINE CALFLTCND (CEILING,FLTCND) use vrbls2d, only: vis - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: jsta, jend, im, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL, DIMENSION(IM,jsta:jend), INTENT(IN) :: CEILING - REAL, DIMENSION(IM,jsta:jend), INTENT(INOUT) :: FLTCND + REAL, DIMENSION(ista:iend,jsta:jend), INTENT(IN) :: CEILING + REAL, DIMENSION(ista:iend,jsta:jend), INTENT(INOUT) :: FLTCND REAL CEIL,VISI integer I,J ! @@ -519,7 +564,7 @@ SUBROUTINE CALFLTCND (CEILING,FLTCND) ! ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CEILING(I,J) feet diff --git a/sorc/ncep_post.fd/AllGETHERV_GSD.f b/sorc/ncep_post.fd/AllGETHERV_GSD.f index ae7e64021..63aef1f8d 100644 --- a/sorc/ncep_post.fd/AllGETHERV_GSD.f +++ b/sorc/ncep_post.fd/AllGETHERV_GSD.f @@ -9,8 +9,9 @@ SUBROUTINE AllGETHERV(GRID1) ! ! PROGRAM HISTORY LOG: ! +! 21-09-02 Bo Cui - Decompose UPP in X direction - use ctlblk_mod, only : im,jm,num_procs,me,jsta,jend,mpi_comm_comp + use ctlblk_mod, only : im,jm,num_procs,me,jsta,jend,ista,iend,mpi_comm_comp implicit none @@ -22,11 +23,11 @@ SUBROUTINE AllGETHERV(GRID1) REAL GRID1(IM,JM) REAL ibufrecv(IM*JM) - REAL ibufsend(im*(jend-jsta+1)) + REAL ibufsend((iend-ista+1)*(jend-jsta+1)) integer SENDCOUNT,RECVCOUNTS(num_procs),DISPLS(num_procs) ! ! write(*,*) 'check mpi', im,jm,num_procs,me,jsta,jend - SENDCOUNT=im*(jend-jsta+1) + SENDCOUNT=(iend-ista+1)*(jend-jsta+1) call MPI_ALLGATHER(SENDCOUNT, 1, MPI_INTEGER, RECVCOUNTS,1 , & MPI_INTEGER, mpi_comm_comp, ierr) DISPLS(1)=0 @@ -40,7 +41,7 @@ SUBROUTINE AllGETHERV(GRID1) ij=0 ibufsend=0.0 do j=jsta,jend - do i=1,IM + do i=ista,iend ij=ij+1 ibufsend(ij)=GRID1(i,j) enddo diff --git a/sorc/ncep_post.fd/BNDLYR.f b/sorc/ncep_post.fd/BNDLYR.f index 4d0564a8f..72e4cb950 100644 --- a/sorc/ncep_post.fd/BNDLYR.f +++ b/sorc/ncep_post.fd/BNDLYR.f @@ -42,6 +42,7 @@ !> - 02-01-15 MIKE BALDWIN - WRF VERSION !> - 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE !> - 21-08-20 Wen Meng - Retrict computation fro undefined points. +!> - 21-09-02 Bo Cui - Decompose UPP in X direction. !> !> @author Russ Treadon W/NP2 @date 1993-01-29 SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & @@ -53,7 +54,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & use masks, only: lmh use params_mod, only: d00, gi, pq0, a2, a3, a4 use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, modelname, & - jsta_m, jend_m, im, nbnd, spval + jsta_m, jend_m, im, nbnd, spval, ista_2l, iend_2u, ista_m, iend_m, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use gridspec_mod, only: gridtype use upp_physics, only: FPVSNEW @@ -63,12 +64,12 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & ! DECLARE VARIABLES. ! real,PARAMETER :: DPBND=30.E2 - integer, dimension(IM,jsta:jend,NBND),intent(inout) :: LVLBND - real, dimension(IM,jsta:jend,NBND),intent(inout) :: PBND,TBND, & + integer, dimension(ista:iend,jsta:jend,NBND),intent(inout) :: LVLBND + real, dimension(ista:iend,jsta:jend,NBND),intent(inout) :: PBND,TBND, & QBND,RHBND,UBND,VBND,WBND,OMGBND,PWTBND,QCNVBND - REAL Q1D(IM,JSTA_2L:JEND_2U),V1D(IM,JSTA_2L:JEND_2U), & - U1D(IM,JSTA_2L:JEND_2U),QCNV1D(IM,JSTA_2L:JEND_2U) + REAL Q1D(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),V1D(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U), & + U1D(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),QCNV1D(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U) ! REAL, ALLOCATABLE :: PBINT(:,:,:),QSBND(:,:,:) REAL, ALLOCATABLE :: PSUM(:,:,:), QCNVG(:,:,:) @@ -81,19 +82,19 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & !***************************************************************************** ! START BNDLYR HERE ! - ALLOCATE (PBINT(IM,JSTA_2L:JEND_2U,NBND+1)) - ALLOCATE (QSBND(IM,JSTA_2L:JEND_2U,NBND)) - ALLOCATE (PSUM(IM,JSTA_2L:JEND_2U,NBND)) - ALLOCATE (QCNVG(IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE (PVSUM(IM,JSTA_2L:JEND_2U,NBND)) - ALLOCATE (NSUM(IM,JSTA_2L:JEND_2U,NBND)) + ALLOCATE (PBINT(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NBND+1)) + ALLOCATE (QSBND(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NBND)) + ALLOCATE (PSUM(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NBND)) + ALLOCATE (QCNVG(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) + ALLOCATE (PVSUM(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NBND)) + ALLOCATE (NSUM(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NBND)) ! ! LOOP OVER HORIZONTAL GRID. AT EACH MASS POINT COMPUTE ! PRESSURE AT THE INTERFACE OF EACH BOUNDARY LAYER. ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PBINT(I,J,1) = PINT(I,J,NINT(LMH(I,J))+1) ENDDO ENDDO @@ -101,7 +102,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & DO LBND=2,NBND+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PBINT(I,J,LBND) = PBINT(I,J,LBND-1) - DPBND ENDDO ENDDO @@ -111,7 +112,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & DO L=1,LM !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U Q1D(I,J) = Q(I,J,L) U1D(I,J) = UH(I,J,L) V1D(I,J) = VH(I,J,L) @@ -120,7 +121,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & CALL CALMCVG(Q1D,U1D,V1D,QCNV1D) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QCNVG(I,J,L)=QCNV1D(I,J) ENDDO ENDDO @@ -136,7 +137,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & DO LBND=1,NBND !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PBND(I,J,LBND) = D00 TBND(I,J,LBND) = D00 QBND(I,J,LBND) = D00 @@ -159,7 +160,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & DO L=1,LM !$omp parallel do private(i,j,dp,pm,es,qsat) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! PM = PMID(I,J,L) IF(PM @file -! +!> @brief bound() clips data in passed array. +!> +!> @author Russ Treadon W/NP2 @date 1993-01-18 + +!> This routine bounds data in the passed array +!> FLD (im x jm elements long) and clips data values such +!> that on exiting the routine +!> @code +!> FMIN <= FLD(I,J) <= FMAX +!> @endcode +!> for all points. +!> +!> @param[in] FMIN Lower (inclusive) bound for data. +!> @param[in] FMAX Upper (inclusive) bound for data. +!> @param[out] FLD Array whose elements are bounded by [FMIN,FMAX]. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-01-18 | Russ Treadon | Initial +!> 1993-05-07 | Russ Treadon | Added DOCBLOC +!> 1998-05-29 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2021-09002 | Bo Cui | Decompose UPP in X direction !> -!! . . . -!! SUBPROGRAM: BOUND CLIPS DATA IN PASSED ARRAY -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-01-18 -!! -!! ABSTRACT: THIS ROUTINE BOUNDS DATA IN THE PASSED ARRAY -!! FLD (IMxJM ELEMENTS LONG) AND CLIPS DATA VALUES SUCH -!! THAT ON EXITING THE ROUTINE -!! FMIN <= FLD(I,J) <= FMAX -!! FOR ALL POINTS. -!! -!! -!! PROGRAM HISTORY LOG: -!! 93-01-18 RUSS TREADON -!! 93-05-07 RUSS TREADON - ADDED DOCBLOC -!! 98-05-29 BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! -!! USAGE: CALL bound(fld,fmin,fmax) -!! INPUT ARGUMENT LIST: -!! FMIN - LOWER (INCLUSIVE) BOUND FOR DATA. -!! FMAX - UPPER (INCLUSIVE) BOUND FOR DATA. -!! -!! OUTPUT ARGUMENT LIST: -!! FLD - ARRAY WHOSE ELEMENTS ARE BOUNDED BY [FMIN,FMAX]. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @author Russ Treadon W/NP2 @date 1993-01-18 SUBROUTINE BOUND(FLD,FMIN,FMAX) ! - use ctlblk_mod, only: jsta, jend, spval, im, jm + use ctlblk_mod, only: jsta, jend, spval, im, jm, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -59,7 +45,7 @@ SUBROUTINE BOUND(FLD,FMIN,FMAX) ! BOUND ARRAY. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(fld(i,j) /= spval) then FLD(I,J) = min(FMAX, MAX(FMIN,FLD(I,J))) end if diff --git a/sorc/ncep_post.fd/CALDRG.f b/sorc/ncep_post.fd/CALDRG.f index 88f0d6038..352d6cf59 100644 --- a/sorc/ncep_post.fd/CALDRG.f +++ b/sorc/ncep_post.fd/CALDRG.f @@ -1,42 +1,23 @@ !> @file -! -!> SUBPROGRAM: CALDRG COMPUTE DRAG COEFFICIENT -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-09-01 -!! -!! ABSTRACT: THIS ROUTINE COMPUTES A SURFACE LAYER DRAG -!! COEFFICIENT USING EQUATION (7.4.1A) IN "AN INTRODUCTION -!! TO BOUNDARY LAYER METEOROLOGY" BY STULL (1988, KLUWER -!! ACADEMIC PUBLISHERS). -!! -!! PROGRAM HISTORY LOG: -!! 93-09-01 RUSS TREADON -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 05-02-22 H CHUANG - ADD WRF NMM COMPONENTS -!! -!! USAGE: CALL CALDRG(DRAGCO) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! DRAGCO - SURFACE LAYER DRAG COEFFICIENT -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - LOOPS -!! SRFDSP -!! PVRBLS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes drag cofficient. +! +!> This rountine computes a surface layer drag coefficient using +!> equation (7.4.1A) in ["An introduction to boundary layer +!> meteorology" by Stull (1988, Kluwer Academic +!> Publishers)](https://link.springer.com/book/10.1007/978-94-009-3027-8). +!> +!> @param[out] DRAGCO surface layer drag coefficient. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-09-01 | Russ Treadon | Initial +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2005-02-22 | H Chuang | Add WRF NMM components +!> +!> @author Russ Treadon W/NP2 @date 1993-09-01 SUBROUTINE CALDRG(DRAGCO) ! @@ -46,7 +27,7 @@ SUBROUTINE CALDRG(DRAGCO) use masks, only: lmh use params_mod, only: d00, d50, d25 use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, modelname, spval, im, jm, & - jsta_2l, jend_2u + jsta_2l, jend_2u, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -54,7 +35,7 @@ SUBROUTINE CALDRG(DRAGCO) ! INCLUDE/SET PARAMETERS. ! ! DECLARE VARIABLES. - REAL,intent(inout) :: DRAGCO(IM,jsta_2l:jend_2u) + REAL,intent(inout) :: DRAGCO(ista_2l:iend_2u,jsta_2l:jend_2u) INTEGER IHE(JM),IHW(JM) integer I,J,LHMK,IE,IW,LMHK real UBAR,VBAR,WSPDSQ,USTRSQ,SUMU,SUMV,ULMH,VLMH,UZ0H,VZ0H @@ -66,7 +47,7 @@ SUBROUTINE CALDRG(DRAGCO) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! DRAGCO(I,J) = D00 DRAGCO(I,J) = 0.0 @@ -76,7 +57,7 @@ SUBROUTINE CALDRG(DRAGCO) IF(gridtype=='A')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! IF (USTAR(I,J) /= SPVAL) THEN @@ -110,7 +91,7 @@ SUBROUTINE CALDRG(DRAGCO) ENDDO DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! ! COMPUTE A MEAN MASS POINT WIND IN THE ! FIRST ATMOSPHERIC ETA LAYER. @@ -147,7 +128,7 @@ SUBROUTINE CALDRG(DRAGCO) END DO ELSE IF(gridtype=='B')THEN DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! ! COMPUTE A MEAN MASS POINT WIND IN THE ! FIRST ATMOSPHERIC ETA LAYER. @@ -193,7 +174,7 @@ SUBROUTINE CALDRG(DRAGCO) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DRAGCO(I,J) = SPVAL ENDDO ENDDO diff --git a/sorc/ncep_post.fd/CALDWP.f b/sorc/ncep_post.fd/CALDWP.f index aa2405e05..02f309a94 100644 --- a/sorc/ncep_post.fd/CALDWP.f +++ b/sorc/ncep_post.fd/CALDWP.f @@ -1,58 +1,39 @@ !> @file +!> @brief Subroutine related to dewpoint temperature. ! -!> SUBPROGRAM: CALDWP COMPUTES -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: COMPUTES DEWPOINT FROM P, T, AND Q -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-10-04 RUSS TREADON - ADDED CHECK TO BOUND DEWPOINT -!! TEMPERATURE TO NOT EXCEED THE -!! AMBIENT TEMPERATURE. -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 21-07-23 Wen Meng - Retrict computation from undefined points -!! -!! USAGE: CALL CALDWP(P1D,Q1D,TDWP,T1D) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! Q1D - SPECIFIC HUMIDITY (KG/KG) -!! T1D - TEMPERATURE (K) -!! -!! OUTPUT ARGUMENT LIST: -!! TDWP - DEWPOINT TEMPERATURE (K) - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! DEWPOINT - COMPUTES DEWPOINT GIVEN VAPOR PRESSURE. -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> Computes dewpoint from P, T, and Q. +!> +!> @param[in] P1D Pressure (Pa). +!> @param[in] Q1D Specific humidity (kg/kg). +!> @param[in] T1D Temperature (K). +!> @param[out] TDWP Dewpoint temperature (K). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-10-04 | Russ Treadon | Added check to bound dewpoint temperature to not exceed the ambient temperature. +!> 1998-06-08 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2021-07-23 | Wen Meng | Retrict computation from undefined points +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE CALDWP(P1D,Q1D,TDWP,T1D) ! ! ! SET PARAMETERS. use params_mod, only: eps, oneps, d001, h1m12 - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: jsta, jend, im, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta:jend),intent(in) :: P1D,Q1D,T1D - REAL,dimension(IM,jsta:jend),intent(inout) :: TDWP + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1D,Q1D,T1D + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: TDWP - REAL EVP(IM,jsta:jend) + REAL EVP(ista:iend,jsta:jend) integer I,J ! !**************************************************************************** @@ -62,7 +43,7 @@ SUBROUTINE CALDWP(P1D,Q1D,TDWP,T1D) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(P1D(I,j) @file -! . . . -!> SUBPROGRAM: CALGUST COMPUTE MAX WIND LEVEL -!! PRGRMMR: MANIKIN ORG: W/NP2 DATE: 97-03-04 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES SURFACE WIND GUST BY MIXING -!! DOWN MOMENTUM FROM THE LEVEL AT THE HEIGHT OF THE PBL -!! -!! -!! PROGRAM HISTORY LOG: -!! 03-10-15 GEOFF MANIKIN -!! 05-03-09 H CHUANG - WRF VERSION -!! 05-07-07 BINBIN ZHOU - ADD RSM -!! 15-03-11 S Moorthi - set sfcwind to spval if u10 and v10 are spvals -!! for A grid and set gust to just wind -!! (in GSM with nemsio, it appears u10 & v10 have spval) -!! -!! USAGE: CALL CALGUST(GUST) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! GUST - SPEED OF THE MAXIMUM SFC WIND GUST -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! H2V -!! -!! LIBRARY: -!! COMMON - -!! LOOPS -!! OPTIONS -!! MASKS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes max wind level. +! +!> This routine computes surface wind gust by mixing +!> down momentum from the level at the height of the PBL. +!> +!> @param[out] GUST Speed of the maximum surface wind gust. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2003-10-15 | Geoff Manokin | Initial +!> 2005-03-09 | H Chuang | WRF Version +!> 2005-07-07 | Binbin Zhou | Add RSM +!> 2015-03-11 | S Moorthi | Set sfcwind to spval if u10 and v10 are spvals for A grid and set gust to just wind (in GSM with nemsio, it appears u10 & v10 have spval) +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Geoff Manikin W/NP2 @date 1997-03-04 + SUBROUTINE CALGUST(LPBL,ZPBL,GUST) ! @@ -49,7 +25,7 @@ SUBROUTINE CALGUST(LPBL,ZPBL,GUST) use vrbls2d , only: u10h, v10h, u10,v10, fis use params_mod, only: d25, gi use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, num_procs, mpi_comm_comp, lm,& - modelname, im, jm, jsta_2l, jend_2u + modelname, im, jm, jsta_2l, jend_2u, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none @@ -60,9 +36,9 @@ SUBROUTINE CALGUST(LPBL,ZPBL,GUST) ! ! DECLARE VARIABLES. ! - INTEGER,intent(in) :: LPBL(IM,jsta_2l:jend_2u) - REAL,intent(in) :: ZPBL(IM,jsta_2l:jend_2u) - REAL,intent(inout) :: GUST(IM,jsta_2l:jend_2u) + INTEGER,intent(in) :: LPBL(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL,intent(in) :: ZPBL(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL,intent(inout) :: GUST(ista_2l:iend_2u,jsta_2l:jend_2u) integer I,J,IE,IW, L, K, ISTART, ISTOP, JSTART, JSTOP integer LMIN,LXXX,IERR @@ -76,25 +52,25 @@ SUBROUTINE CALGUST(LPBL,ZPBL,GUST) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GUST(I,J) = SPVAL ENDDO ENDDO IF(gridtype == 'A') THEN - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND ELSE - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M if ( num_procs > 1 ) then !CALL EXCH(U10(1,jsta_2l)) !CALL EXCH(V10(1,jsta_2l)) - LMIN = max(1, minval(lpbl(1:im,jsta:jend))) + LMIN = max(1, minval(lpbl(ista:iend,jsta:jend))) CALL MPI_ALLREDUCE(LMIN,LXXX,1,MPI_INTEGER,MPI_MIN,MPI_COMM_COMP,IERR) DO L=LXXX,LM CALL EXCH(UH(1,jsta_2l,L)) diff --git a/sorc/ncep_post.fd/CALHEL.f b/sorc/ncep_post.fd/CALHEL.f index 8520bf5cd..a69c4260b 100644 --- a/sorc/ncep_post.fd/CALHEL.f +++ b/sorc/ncep_post.fd/CALHEL.f @@ -1,80 +1,44 @@ !> @file -! . . . -!> SUBPROGRAM: CALHEL COMPUTES STORM RELATIVE HELICITY -!! PRGRMMR: BALDWIN ORG: W/NP2 DATE: 94-08-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES ESTIMATED STORM MOTION AND -!! STORM-RELATIVE ENVIRONMENTAL HELICITY. -!! (DAVIES-JONES ET AL 1990) THE ALGORITHM PROCEEDS AS -!! FOLLOWS. -!! -!! THE STORM MOTION COMPUTATION NO LONGER EMPLOYS THE DAVIES AND -!! JOHNS (1993) METHOD WHICH DEFINED STORM MOTION AS 30 DEGREES TO -!! THE RIGHT OF THE 0-6 KM MEAN WIND AT 75% OF THE SPEED FOR MEAN -!! SPEEDS LESS THAN 15 M/S AND 20 DEGREES TO THE RIGHT FOR SPEEDS -!! GREATER THAN 15 M/S. INSTEAD, WE NOW USE THE DYNAMIC METHOD -!! (BUNKERS ET AL. 1998) WHICH HAS BEEN FOUND TO DO BETTER IN -!! CASES WITH 'NON-CLASSIC' HODOGRAPHS (SUCH AS NORTHWEST-FLOW -!! EVENTS) AND DO AS WELL OR BETTER THAN THE OLD METHOD IN MORE -!! CLASSIC SITUATIONS. -!! -!! PROGRAM HISTORY LOG: -!! 94-08-22 MICHAEL BALDWIN -!! 97-03-27 MICHAEL BALDWIN - SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-01-10 G MANIKIN - CHANGED TO BUNKERS METHOD -!! 02-05-22 G MANIKIN - NOW ALLOW CHOICE OF COMPUTING -!! HELICITY OVER TWO DIFFERENT -!! (0-1 and 0-3 KM) DEPTHS -!! 03-03-25 G MANIKIN - MODIFIED CODE TO COMPUTE MEAN WINDS -!! USING ARITHMETIC AVERAGES INSTEAD OF -!! MASS WEIGHTING; DIFFERENCES ARE MINOR -!! BUT WANT TO BE CONSISTENT WITH THE -!! BUNKERS METHOD -!! 04-04-16 M PYLE - MINIMAL MODIFICATIONS, BUT PUT INTO -!! NMM WRFPOST CODE -!! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! -!! USAGE: CALHEL(UST,VST,HELI) -!! INPUT ARGUMENT LIST: -!! DPTH - DEPTH IN METERS OVER WHICH HELICITY SHOULD BE COMPUTED; -!! ALLOWS ONE TO DISTINGUISH 0-3 KM AND 0-1 KM VALUES -!! -!! OUTPUT ARGUMENT LIST: -!! UST - ESTIMATED U COMPONENT (M/S) OF STORM MOTION. -!! VST - ESTIMATED V COMPONENT (M/S) OF STORM MOTION. -!! HELI - STORM-RELATIVE HELICITY (M**2/S**2) -!! CRA -!! USHR1 - U COMPONENT (M/S) OF 0-1 KM SHEAR -!! VSHR1 - V COMPONENT (M/S) OF 0-1 KM SHEAR -!! USHR6 - U COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! VSHR6 - V COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! CRA - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - VRBLS -!! LOOPS -!! PHYS -!! EXTRA -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes storm relative helicity. +! +!> This routine computes estimated storm motion and storm-relative +!> environmental helicity. (Davies-Jones et al 1990) the algorithm +!> processd as follows. +!> +!> The storm motion computation no longer employs the Davies and Johns (1993) +!> method which defined storm motion as 30 degress to the right of the 0-6 km +!> mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees +!> to the right for speeds greater than 15 m/s. Instead, we now use the dynamic +!> method (Bunkers et al. 1988) which has been found to do better in cases with +!> 'non-classic' hodographs (such as Northwest-flow events) and do as well or +!> better than the old method in more classic situations. +!> +!> @param[in] DPTH Depth in meters over whcih helicity should be computed; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[out] UST Estimated U Component (m/s) Of Storm motion. +!> @param[out] VST Estimated V Component (m/s) Of Storm motion. +!> @param[out] HELI Storm-relative heliciry (m**2/s**2). +!> @param[out] USHR1 U Component (m/s) Of 0-1 km shear. +!> @param[out] VSHR1 V Component (m/s) Of 0-1 km shear. +!> @param[out] USHR6 U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> @param[out] VSHR6 V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1994-08-22 | Michael Baldwin | Initial +!> 1997-03-27 | Michael Baldwin | Speed up code +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-01-10 | G Manikin | Changed to Bunkers method +!> 2002-05-22 | G Manikin | Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths +!> 2003-03-25 | G Manikin | Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method +!> 2004-04-16 | M Pyle | Minimal modifications but put into NMM WRFPOST code +!> 2005-02-25 | H Chuang | Add computation for ARW A grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A grid +!> 2019-10-30 | Bo Cui | Remove "goto" statement +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Michael Baldwin W/NP2 @date 1994-08-22 SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! @@ -84,7 +48,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) use params_mod, only: g use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, & - lm, im, jm, me, spval + lm, im, jm, me, spval, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -102,10 +67,10 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! DECLARE VARIABLES ! real,intent(in) :: DEPTH(2) - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: UST,VST - REAL,dimension(IM,jsta_2l:jend_2u,2),intent(out) :: HELI + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: UST,VST + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,2),intent(out) :: HELI ! - real, dimension(im,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & UST1, VST1, USHR1, VSHR1, & USHR6, VSHR6, U1, V1, U2, V2, & HGT1, HGT2, UMEAN, VMEAN @@ -120,7 +85,7 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM) ! CRA - integer, dimension(im,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 + integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM) ! CRA ! INTEGER L1(IM,JM),L2(IM,JM) @@ -140,7 +105,7 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UST(I,J) = 0.0 VST(I,J) = 0.0 HELI(I,J,1) = 0.0 @@ -180,8 +145,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -191,8 +156,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -202,8 +167,8 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -218,9 +183,9 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6) ! END DO ! !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L = 1,LM - IF(gridtype /= 'A') CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + IF(gridtype /= 'A') CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) diff --git a/sorc/ncep_post.fd/CALHEL2.f b/sorc/ncep_post.fd/CALHEL2.f index c7678b1c9..2c1bb8460 100644 --- a/sorc/ncep_post.fd/CALHEL2.f +++ b/sorc/ncep_post.fd/CALHEL2.f @@ -1,84 +1,47 @@ !> @file -! . . . -!> SUBPROGRAM: CALHEL COMPUTES STORM RELATIVE HELICITY -!! PRGRMMR: BALDWIN ORG: W/NP2 DATE: 94-08-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES ESTIMATED STORM MOTION AND -!! STORM-RELATIVE ENVIRONMENTAL HELICITY. -!! (DAVIES-JONES ET AL 1990) THE ALGORITHM PROCEEDS AS -!! FOLLOWS. -!! -!! THE STORM MOTION COMPUTATION NO LONGER EMPLOYS THE DAVIES AND -!! JOHNS (1993) METHOD WHICH DEFINED STORM MOTION AS 30 DEGREES TO -!! THE RIGHT OF THE 0-6 KM MEAN WIND AT 75% OF THE SPEED FOR MEAN -!! SPEEDS LESS THAN 15 M/S AND 20 DEGREES TO THE RIGHT FOR SPEEDS -!! GREATER THAN 15 M/S. INSTEAD, WE NOW USE THE DYNAMIC METHOD -!! (BUNKERS ET AL. 1998) WHICH HAS BEEN FOUND TO DO BETTER IN -!! CASES WITH 'NON-CLASSIC' HODOGRAPHS (SUCH AS NORTHWEST-FLOW -!! EVENTS) AND DO AS WELL OR BETTER THAN THE OLD METHOD IN MORE -!! CLASSIC SITUATIONS. -!! -!! PROGRAM HISTORY LOG: -!! 94-08-22 MICHAEL BALDWIN -!! 97-03-27 MICHAEL BALDWIN - SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-01-10 G MANIKIN - CHANGED TO BUNKERS METHOD -!! 02-05-22 G MANIKIN - NOW ALLOW CHOICE OF COMPUTING -!! HELICITY OVER TWO DIFFERENT -!! (0-1 and 0-3 KM) DEPTHS -!! 03-03-25 G MANIKIN - MODIFIED CODE TO COMPUTE MEAN WINDS -!! USING ARITHMETIC AVERAGES INSTEAD OF -!! MASS WEIGHTING; DIFFERENCES ARE MINOR -!! BUT WANT TO BE CONSISTENT WITH THE -!! BUNKERS METHOD -!! 04-04-16 M PYLE - MINIMAL MODIFICATIONS, BUT PUT INTO -!! NMM WRFPOST CODE -!! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 19-09-03 J MENG - MODIFIED TO COMPUTE EFFECTIVE HELICITY -!! AND CRITICAL ANGLE -!! -!! USAGE: CALHEL(UST,VST,HELI) -!! INPUT ARGUMENT LIST: -!! LLOW - LOWER BOUND CAPE>=100 AND CINS>=-250 -!! LUPP - UPPER BOUND CAPE< 100 OR CINS< -250 -!! DPTH - DEPTH IN METERS OVER WHICH HELICITY SHOULD BE COMPUTED; -!! ALLOWS ONE TO DISTINGUISH 0-3 KM AND 0-1 KM VALUES -!! -!! OUTPUT ARGUMENT LIST: -!! UST - ESTIMATED U COMPONENT (M/S) OF STORM MOTION. -!! VST - ESTIMATED V COMPONENT (M/S) OF STORM MOTION. -!! HELI - STORM-RELATIVE HELICITY (M**2/S**2) -!! CANGLE - CRITICAL ANGLE -!! CRA -!! USHR1 - U COMPONENT (M/S) OF 0-1 KM SHEAR -!! VSHR1 - V COMPONENT (M/S) OF 0-1 KM SHEAR -!! USHR6 - U COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! VSHR6 - V COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! CRA - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - VRBLS -!! LOOPS -!! PHYS -!! EXTRA -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes storm relative helicity. +! +!> This routine computes estimated storm motion and storm-relative +!> environmental helicity. (Davies-Jones et al 1990) the algorithm +!> processd as follows. +!> +!> The storm motion computation no longer employs the Davies and Johns (1993) +!> method which defined storm motion as 30 degress to the right of the 0-6 km +!> mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees +!> to the right for speeds greater than 15 m/s. Instead, we now use the dynamic +!> method (Bunkers et al. 1988) which has been found to do better in cases with +!> 'non-classic' hodographs (such as Northwest-flow events) and do as well or +!> better than the old method in more classic situations. +!> +!> @param[in] LLOW Lower bound CAPE>=100 and CINS>=-250. +!> @param[in] LUPP Upper bound CAPE< 100 or CINS< -250; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[in] DPTH Depth in meters over whcih helicity should be computed; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[out] UST Estimated U Component (m/s) Of Storm motion. +!> @param[out] VST Estimated V Component (m/s) Of Storm motion. +!> @param[out] HELI Storm-relative heliciry (m**2/s**2). +!> @param[out] CANGLE Critical angle. +!> @param[out] USHR1 U Component (m/s) Of 0-1 km shear. +!> @param[out] VSHR1 V Component (m/s) Of 0-1 km shear. +!> @param[out] USHR6 U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> @param[out] VSHR6 V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1994-08-22 | Michael Baldwin | Initial +!> 1997-03-27 | Michael Baldwin | Speed up code +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-01-10 | G Manikin | Changed to Bunkers method +!> 2002-05-22 | G Manikin | Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths +!> 2003-03-25 | G Manikin | Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method +!> 2004-04-16 | M Pyle | Minimal modifications but put into NMM WRFPOST code +!> 2005-02-25 | H Chuang | Add computation for ARW A grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A grid +!> 2019-09-03 | J Meng | Modified to compute effective helicity and critical angle +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Michael Baldwin W/NP2 @date 1994-08-22 SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! @@ -88,7 +51,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) use params_mod, only: g use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, & - lm, im, jm, me, spval + lm, im, jm, me, spval, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -106,17 +70,17 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! ! DECLARE VARIABLES ! - integer,dimension(IM,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP + integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP real,intent(in) :: DEPTH(2) - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: UST,VST - REAL,dimension(IM,jsta_2l:jend_2u,2),intent(out) :: HELI - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: CANGLE + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: UST,VST + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,2),intent(out) :: HELI + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: CANGLE ! - real, dimension(im,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & UST1, VST1, USHR1, VSHR1, & USHR6, VSHR6, U1, V1, U2, V2, & HGT1, HGT2, UMEAN, VMEAN - real, dimension(im,jsta_2l:jend_2u) :: USHR05,VSHR05 + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: USHR05,VSHR05 ! REAL HTSFC(IM,JM) ! @@ -129,7 +93,7 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM) ! CRA - integer, dimension(im,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 + integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM) ! CRA ! INTEGER L1(IM,JM),L2(IM,JM) @@ -148,7 +112,7 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UST(I,J) = 0.0 VST(I,J) = 0.0 HELI(I,J,1) = 0.0 @@ -191,8 +155,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -202,8 +166,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -213,8 +177,8 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -229,9 +193,9 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE) ! END DO ! !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L = 1,LM - IF(gridtype /= 'A') CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + IF(gridtype /= 'A') CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) diff --git a/sorc/ncep_post.fd/CALHEL3.f b/sorc/ncep_post.fd/CALHEL3.f index 22a6d8480..abebc0013 100644 --- a/sorc/ncep_post.fd/CALHEL3.f +++ b/sorc/ncep_post.fd/CALHEL3.f @@ -1,82 +1,47 @@ !> @file -! . . . -!> SUBPROGRAM: CALHEL COMPUTES STORM RELATIVE HELICITY -!! PRGRMMR: BALDWIN ORG: W/NP2 DATE: 94-08-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES ESTIMATED STORM MOTION AND -!! STORM-RELATIVE ENVIRONMENTAL HELICITY. -!! (DAVIES-JONES ET AL 1990) THE ALGORITHM PROCEEDS AS -!! FOLLOWS. -!! -!! THE STORM MOTION COMPUTATION NO LONGER EMPLOYS THE DAVIES AND -!! JOHNS (1993) METHOD WHICH DEFINED STORM MOTION AS 30 DEGREES TO -!! THE RIGHT OF THE 0-6 KM MEAN WIND AT 75% OF THE SPEED FOR MEAN -!! SPEEDS LESS THAN 15 M/S AND 20 DEGREES TO THE RIGHT FOR SPEEDS -!! GREATER THAN 15 M/S. INSTEAD, WE NOW USE THE DYNAMIC METHOD -!! (BUNKERS ET AL. 1998) WHICH HAS BEEN FOUND TO DO BETTER IN -!! CASES WITH 'NON-CLASSIC' HODOGRAPHS (SUCH AS NORTHWEST-FLOW -!! EVENTS) AND DO AS WELL OR BETTER THAN THE OLD METHOD IN MORE -!! CLASSIC SITUATIONS. -!! -!! PROGRAM HISTORY LOG: -!! 94-08-22 MICHAEL BALDWIN -!! 97-03-27 MICHAEL BALDWIN - SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-01-10 G MANIKIN - CHANGED TO BUNKERS METHOD -!! 02-05-22 G MANIKIN - NOW ALLOW CHOICE OF COMPUTING -!! HELICITY OVER TWO DIFFERENT -!! (0-1 and 0-3 KM) DEPTHS -!! 03-03-25 G MANIKIN - MODIFIED CODE TO COMPUTE MEAN WINDS -!! USING ARITHMETIC AVERAGES INSTEAD OF -!! MASS WEIGHTING; DIFFERENCES ARE MINOR -!! BUT WANT TO BE CONSISTENT WITH THE -!! BUNKERS METHOD -!! 04-04-16 M PYLE - MINIMAL MODIFICATIONS, BUT PUT INTO -!! NMM WRFPOST CODE -!! 05=02-25 H CHUANG - ADD COMPUTATION FOR ARW A GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! 19-09-03 J MENG - MODIFIED TO COMPUTE EFFECTIVE HELICITY -!! AND CRITICAL ANGLE -!! 21-03-15 E COLON - CALHEL2 MODIFIED TO COMPUTE EFFECTIVE -!! RATHER THAN FIXED LAYER HELICITY -!! USAGE: CALHEL3(UST,VST,HELI) -!! INPUT ARGUMENT LIST: -!! LLOW - LOWER BOUND CAPE>=100 AND CINS>=-250 -!! LUPP - UPPER BOUND CAPE< 100 OR CINS< -250 -!! -!! OUTPUT ARGUMENT LIST: -!! UST - ESTIMATED U COMPONENT (M/S) OF STORM MOTION. -!! VST - ESTIMATED V COMPONENT (M/S) OF STORM MOTION. -!! HELI - STORM-RELATIVE HELICITY (M**2/S**2) -!! CRA -!! USHR1 - U COMPONENT (M/S) OF 0-1 KM SHEAR -!! VSHR1 - V COMPONENT (M/S) OF 0-1 KM SHEAR -!! USHR6 - U COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! VSHR6 - V COMPONENT (M/S) OF 0-0.5 to 5.5-6.0 KM SHEAR -!! CRA - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - VRBLS -!! LOOPS -!! PHYS -!! EXTRA -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes storm relative helicity. +! +!> This routine computes estimated storm motion and storm-relative +!> environmental helicity. (Davies-Jones et al 1990) the algorithm +!> processd as follows. +!> +!> The storm motion computation no longer employs the Davies and Johns (1993) +!> method which defined storm motion as 30 degress to the right of the 0-6 km +!> mean wind at 75% of the speed for mean speeds less than 15 m/s and 20 degrees +!> to the right for speeds greater than 15 m/s. Instead, we now use the dynamic +!> method (Bunkers et al. 1988) which has been found to do better in cases with +!> 'non-classic' hodographs (such as Northwest-flow events) and do as well or +!> better than the old method in more classic situations. +!> +!> @param[in] LLOW Lower bound CAPE>=100 and CINS>=-250. +!> @param[in] LUPP Upper bound CAPE< 100 or CINS< -250; allows one to distinguish 0-3 km and 0-1 km values. +!> @param[out] UST Estimated U Component (m/s) Of Storm motion. +!> @param[out] VST Estimated V Component (m/s) Of Storm motion. +!> @param[out] HELI Storm-relative heliciry (m**2/s**2). +!> @param[out] CANGLE Critical angle. +!> @param[out] USHR1 U Component (m/s) Of 0-1 km shear. +!> @param[out] VSHR1 V Component (m/s) Of 0-1 km shear. +!> @param[out] USHR6 U Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> @param[out] VSHR6 V Component (m/s) Of 0-0.5 to 5.5-6.0 km shear. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1994-08-22 | Michael Baldwin | Initial +!> 1997-03-27 | Michael Baldwin | Speed up code +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-01-10 | G Manikin | Changed to Bunkers method +!> 2002-05-22 | G Manikin | Now allow choice of computing helicity over two different (0-1 and 0-3 km) depths +!> 2003-03-25 | G Manikin | Modified code to compute mean winds using arithmetic averages instead of mass weighting; differences are minor but want to be consistent with the Bunkers method +!> 2004-04-16 | M Pyle | Minimal modifications but put into NMM WRFPOST code +!> 2005-02-25 | H Chuang | Add computation for ARW A grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A grid +!> 2019-09-03 | J Meng | Modified to compute effective helicity and critical angle +!> 2021-03-15 | E Colon | CALHEL2 modified to compute effective rather than fixed layer helicity +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Michael Baldwin W/NP2 @date 1994-08-22 SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! @@ -86,7 +51,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) use params_mod, only: g use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, & - lm, im, jm, me, spval + lm, im, jm, me, spval, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -104,15 +70,15 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! ! DECLARE VARIABLES ! - integer,dimension(IM,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP - REAL,dimension(IM,jsta_2l:jend_2u), intent(out) :: UST,VST - REAL,dimension(IM,jsta_2l:jend_2u),intent(out) :: HELI + integer,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: LLOW, LUPP + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(out) :: UST,VST + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: HELI ! - real, dimension(im,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: HTSFC, UST6, VST6, UST5, VST5, & UST1, VST1, USHR1, VSHR1, & USHR6, VSHR6, U1, V1, U2, V2, & HGT1, HGT2, UMEAN, VMEAN - real, dimension(im,jsta_2l:jend_2u) :: USHR05,VSHR05,ELT,ELB + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: USHR05,VSHR05,ELT,ELB ! REAL HTSFC(IM,JM) ! @@ -125,7 +91,7 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! REAL HGT1(IM,JM),HGT2(IM,JM),UMEAN(IM,JM),VMEAN(IM,JM) ! CRA - integer, dimension(im,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 + integer, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: COUNT6, COUNT5, COUNT1, L1, L2 ! INTEGER COUNT6(IM,JM),COUNT5(IM,JM),COUNT1(IM,JM) ! CRA ! INTEGER L1(IM,JM),L2(IM,JM) @@ -144,7 +110,7 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UST(I,J) = 0.0 VST(I,J) = 0.0 HELI(I,J) = 0.0 @@ -185,8 +151,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -196,8 +162,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -207,8 +173,8 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -223,9 +189,9 @@ SUBROUTINE CALHEL3(LLOW,LUPP,UST,VST,HELI) ! END DO ! !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L = 1,LM - IF(gridtype /= 'A') CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + IF(gridtype /= 'A') CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) diff --git a/sorc/ncep_post.fd/CALLCL.f b/sorc/ncep_post.fd/CALLCL.f index 4b029b758..6cc377511 100644 --- a/sorc/ncep_post.fd/CALLCL.f +++ b/sorc/ncep_post.fd/CALLCL.f @@ -1,50 +1,33 @@ !> @file -! -!> SUBPROGRAM: CALLCL COMPUTES LCL HEIGHTS AND PRESSURE -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-03-15 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE LIFTING CONDENSATION LEVEL -!! PRESSURE AND HEIGHT IN EACH COLUMN AT MASS POINTS. -!! THE HEIGHT IS ABOVE GROUND LEVEL. THE EQUATION USED -!! TO FIND THE LCL PRESSURE IS FROM BOLTAN (1980,MWR) -!! AND IS THE SAME AS THAT USED IN SUBROUTINE CALCAPE. -!! -!! THIS ROUTINE IS A TEST VERSION. STILL TO BE RESOLVED -!! IS THE "BEST" PARCEL TO LIFT. -!! -!! PROGRAM HISTORY LOG: -!! 93-03-15 RUSS TREADON -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 21-07-28 W Meng - Restriction compuatation from undefined grids -!! -!! USAGE: CALL CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) -!! INPUT ARGUMENT LIST: -!! P1D - ARRAY OF PARCEL PRESSURES (PA) -!! T1D - ARRAY OF PARCEL TEMPERATURES (K) -!! Q1D - ARRAY OF PARCEL SPECIFIC HUMIDITIES (KG/KG) -!! -!! OUTPUT ARGUMENT LIST: -!! PLCL - PARCEL PRESSURE AT LCL (PA) -!! ZLCL - PARCEL AGL HEIGHT AT LCL (M) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - LOOPS -!! OPTIONS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes LCL heights and pressure. +!> +!> This routine computes the lifting condensation level +!> pressure and height in each column at mass points. +!> The height is above ground level. The equation used +!> to find the LCL pressure is from Boltan (1980, MWR) +!> and is the same as that used in subroutine CALCAPE. +!> +!> This is a test version. Still to be resolved +!> is the "best" parcel to lift. +!> +!> @param[in] P1D Array of parcel pressures (Pa). +!> @param[in] T1D Array of parcel temperatures (K). +!> @param[in] Q1D Array of parcel specific humidities (kg/kg). +!> @param[out] PLCL Parcel Pressure at LCL (Pa). +!> @param[out] ZLCL Parcel AGL height at LCL (m). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-03-15 | Russ Treadon | Initial +!> 1998-06-16 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2019-10-30 | Bo Cui | Remove "GOTO" Statement +!> 2021-07-28 | W Meng | Restriction compuatation from undefined grids +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-03-15 SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! @@ -53,7 +36,8 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) use vrbls2d, only: fis use masks, only: lmh use params_mod, only: eps, oneps, d01, h1m12, gi, d00 - use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, im + use ctlblk_mod, only: jsta, jend, spval, jsta_m, jend_m, im, & + ista, iend, ista_m, iend_m !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -62,9 +46,9 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta:jend), intent(in) :: P1D,T1D,Q1D - REAL,dimension(IM,jsta:jend), intent(inout) :: PLCL,ZLCL - REAL TLCL(IM,jsta:jend) + REAL,dimension(ista:iend,jsta:jend), intent(in) :: P1D,T1D,Q1D + REAL,dimension(ista:iend,jsta:jend), intent(inout) :: PLCL,ZLCL + REAL TLCL(ista:iend,jsta:jend) integer I,J,L,LLMH real DLPLCL,ZSFC,DZ,DALP,ALPLCL,RMX,EVP,ARG,RKAPA ! @@ -75,7 +59,7 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PLCL(I,J) = SPVAL TLCL(I,J) = SPVAL ZLCL(I,J) = SPVAL @@ -87,8 +71,7 @@ SUBROUTINE CALLCL(P1D,T1D,Q1D,PLCL,ZLCL) ! Bo Cui 10/30/2019, remove "GOTO" statement DO 30 J=JSTA_M,JEND_M - DO 30 I=2,IM-1 -! DO 30 I=1,IM + DO 30 I=ISTA_M,IEND_M IF(P1D(I,J) @file -! -!> SUBPROGRAM: CALMCVG COMPUTES MOISTURE CONVERGENCE -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-01-22 -!! -!! ABSTRACT: -!! GIVEN SPECIFIC HUMIDITY, Q, AND THE U-V WIND COMPONENTS -!! THIS ROUTINE EVALUATES THE VECTOR OPERATION, -!! DEL DOT (Q*VEC) -!! WHERE, -!! DEL IS THE VECTOR GRADIENT OPERATOR, -!! DOT IS THE STANDARD DOT PRODUCT OPERATOR, AND -!! VEC IS THE VECTOR WIND. -!! MINUS ONE TIMES THE RESULTING SCALAR FIELD IS THE -!! MOISTURE CONVERGENCE WHICH IS RETURNED BY THIS ROUTINE. -!! -!! PROGRAM HISTORY LOG: -!! 93-01-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-23 MIKE BALDWIN - WRF C-GRID VERSION -!! 05-07-07 BINBIN ZHOU - ADD RSM A GRID -!! 06-04-25 H CHUANG - BUG FIXES TO CORECTLY COMPUTE MC AT BOUNDARIES -!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY -!! -!! USAGE: CALL CALMCVG(Q1D,U1D,V1D,QCNVG) -!! INPUT ARGUMENT LIST: -!! Q1D - SPECIFIC HUMIDITY AT P-POINTS (KG/KG) -!! U1D - U WIND COMPONENT (M/S) AT P-POINTS -!! V1D - V WIND COMPONENT (M/S) AT P-POINTS -!! -!! OUTPUT ARGUMENT LIST: -!! QCNVG - MOISTURE CONVERGENCE (1/S) AT P-POINTS -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - MASKS -!! DYNAM -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes moisture convergence. +!> +!>

+!> Given specific humidity, Q, and the U-V wind components
+!> This routine evaluates the vector operation, 
+!>                  DEL DOT (Q*VEC)
+!> where,
+!>    DEL is the vector gradient operator,
+!>    DOT is the standard dot product operator, and
+!>    VEC is the vector wind.
+!> Minus one times the resulting scalar field is the 
+!> moisture convergence which is returned by this routine.
+!>
+!> +!> @param[in] Q1D - Specific humidity at P-points (kg/kg). +!> @param[in] U1D - U wind component (m/s) at P-points. +!> @param[in] V1D - V wind component (m/s) at P-points. +!> @param[out] QCNVG - Moisture convergence (1/s) at P-points. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-01-22 | Russ Treadon | Initial +!> 1998-06-08 | T Black | Conversion From 1-D To 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-23 | Mike Baldwin | WRF C-Grid Version +!> 2005-07-07 | Binbin Zhou | Add RSM A Grid +!> 2006-04-25 | H Chuang | Bug fixes to correctly compute MC at boundaries +!> 2021-04-01 | J Meng | Computation on defined points only +!> 2021-09-02 | B CUI | REPLACE EXCH_F to EXCH +!> 2021-09-30 | J MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1993-01-22 SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) ! @@ -56,20 +40,21 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) use masks, only: dx, dy, hbm2 use params_mod, only: d00, d25 use ctlblk_mod, only: jsta_2l, jend_2u, spval, jsta_m, jend_m, & - jsta_m2, jend_m2, im, jm + jsta_m2, jend_m2, im, jm, & + ista_2l, iend_2u, ista_m, iend_m, ista_m2, iend_m2 use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta_2l:jend_2u),intent(in) :: Q1D, U1D, V1D - REAL,dimension(IM,jsta_2l:jend_2u),intent(inout) :: QCNVG + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: Q1D, U1D, V1D + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: QCNVG REAL R2DY, R2DX - REAL, dimension(im,jsta_2l:jend_2u) :: UWND, VWND, QV + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: UWND, VWND, QV INTEGER IHE(JM),IHW(JM),IVE(JM),IVW(JM) - integer I,J,ISTA,IEND + integer I,J,ISTA2,IEND2 real QVDY,QUDX ! !*************************************************************************** @@ -78,9 +63,14 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG) ! ! INITIALIZE MOISTURE CONVERGENCE ARRAY. LOAD TEMPORARY WIND ARRAYS. ! + CALL EXCH(Q1D) + CALL EXCH(U1D) + CALL EXCH(V1D) + !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM +! DO I=1,IM + DO I=ISTA_2L,IEND_2U IF(U1D(I,J) @file -! . . . -!> SUBPROGRAM: CALMIC COMPUTES HYDROMETEORS -!! PRGRMMR: JIN ORG: W/NP2 DATE: 01-08-14 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE MIXING RATIOS OF CLOUD WATER, -!! CLOUD ICE, RAIN, AND SNOW. THE CODE IS BASED ON SUBROUTINES -!! GSMDRIVE & GSMCOLUMN IN THE NMM MODEL. -!! -!! PROGRAM HISTORY LOG: -!! 01-08-14 YI JIN -!! 02-02-11 Brad Ferrier - Minor changes for consistency w/ NMM model -!! 04-11-10 Brad Ferrier - Removed cloud fraction algorithm -!! 04-11-17 H CHUANG - WRF VERSION -!! 14-03-11 B Ferrier - Created new & old versions of this subroutine -!! to process new & old versions of the microphysics -!! -!! USAGE: CALL CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL -!! &, QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! T1D - TEMPERATURE (K) -!! Q1D - SPECIFIC HUMIDITY (KG/KG) -!! C1D - TOTAL CONDENSATE (CWM, KG/KG) -!! FI1D - F_ice (fraction of condensate in form of ice) -!! FR1D - F_rain (fraction of liquid water in form of rain) -!! FS1D - F_RimeF ("Rime Factor", ratio of total ice growth -!! to deposition growth) -!! CUREFL - Radar reflectivity contribution from convection (mm**6/m**3) -!! -!! OUTPUT ARGUMENT LIST: -!! QW1 - CLOUD WATER MIXING RATIO (KG/KG) -!! QI1 - CLOUD ICE MIXING RATIO (KG/KG) -!! QR1 - RAIN MIXING RATIO (KG/KG) -!! QS1 - "SNOW" (precipitation ice) MIXING RATIO (KG/KG) -!! DBZ1 - Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z) -!! DBZR - Equivalent radar reflectivity factor from rain in dBZ -!! DBZI - Equivalent radar reflectivity factor from ice (all forms) in dBZ -!! DBZC - Equivalent radar reflectivity factor from parameterized convection in dBZ -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! FUNCTIONS: -!! FPVS -!! UTILITIES: -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM SP -!! +!> @brief Subroutine that computes hydrometeors. +!> +!> This routin computes the mixing ratios of cloud water, +!> cloud ice, rain, and snow. The code is based on subroutines +!> GSMDRIVE and GSMCOLUMN in the NMM model. +!> +!> @param[in] P1D Pressure (Pa). +!> @param[in] T1D Temperature (K). +!> @param[in] Q1D Specific humidity (kg/kg). +!> @param[in] C1D Total condensate (CWM, kg/kg). +!> @param[in] FI1D F_ice (fraction of condensate in form of ice). +!> @param[in] FR1D F_rain (fraction of liquid water in form of rain). +!> @param[in] FS1D F_RimeF ("Rime Factor", ratio of total ice growth to deposition growth). +!> @param[in] CUREFL Radar reflectivity contribution from convection (mm**6/m**3). +!> @param[out] QW1 Cloud water mixing ratio (kg/kg). +!> @param[out] QI1 Cloud ice mixing ratio (kg/kg). +!> @param[out] QR1 Rain mixing ratio (kg/kg). +!> @param[out] QS1 "Snow" (precipitation ice) mixing ratio (kg/kg). +!> @param[out] DBZ1 Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z). +!> @param[out] DBZR Equivalent radar reflectivity factor from rain in dBZ. +!> @param[out] DBZI Equivalent radar reflectivity factor from ice (all forms) in dBZ. +!> @param[out] DBZC Equivalent radar reflectivity factor from parameterized convection in dBZ. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2001-08-14 | Yi Jin | Initial +!> 2002-02-11 | Brad Ferrier | Minor changes for consistency w/ NMM model +!> 2004-11-10 | Brad Ferrier | Removed cloud fraction algorithm +!> 2004-11-17 | H Chuang | WRF VERSION +!> 2014-03-11 | Brad Ferrier | Created new & old versions of this subroutine to process new & old versions of the microphysics +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Yi Jin W/NP2 @date 2001-08-14 SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1,NLICE1,NRAIN1) ! use params_mod, only: dbzmin, epsq, tfrz, eps, rd, d608 - use ctlblk_mod, only: jsta, jend, jsta_2l,jend_2u,im + use ctlblk_mod, only: jsta, jend, jsta_2l, jend_2u,im, & + ista, iend, ista_2l, iend_2u use cmassi_mod, only: t_ice, rqr_drmin, n0rmin, cn0r_dmrmin, & mdrmin, rqr_drmax, cn0r_dmrmax, mdrmax, n0r0, xmrmin, & xmrmax, massi, cn0r0, mdimin, xmimax, mdimax @@ -70,9 +51,9 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & REAL, PARAMETER :: Cice=1.634e13, Cwet=1./.189, Cboth=Cice/.224, & & NLI_min=1.E3, RFmax=45.259, RQmix=0.1E-3,NSI_max=250.E3 !aligo - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & FS1D,CUREFL - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& DBZI1,DBZC1,NLICE1,NRAIN1 integer I,J @@ -88,7 +69,7 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! Zmin=10.**(0.1*DBZmin) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QW1(I,J)=0. QI1(I,J)=0. QR1(I,J)=0. @@ -102,7 +83,7 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ENDDO ENDDO DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Ztot=0. !--- Total radar reflectivity Zrain=0. !--- Radar reflectivity from rain Zice=0. !--- Radar reflectivity from ice @@ -320,68 +301,42 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1,NLICE1,NRAIN1) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALMICT_old COMPUTES HYDROMETEORS FROM THE OLDER VERSION -! OF THE MICROPHYSICS -! -! PRGRMMR: JIN ORG: W/NP2 DATE: 01-08-14 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES THE MIXING RATIOS OF CLOUD WATER, CLOUD ICE, -! RAIN, AND SNOW. THE CODE IS BASED ON OPTION MP_PHYSICS==95 IN THE -! WRF NAMELIST AND OPTION MICRO='fer' in NMMB CONFIGURE FILES. -! -! PROGRAM HISTORY LOG: -! 01-08-14 YI JIN -! 02-02-11 Brad Ferrier - Minor changes for consistency w/ NMM model -! 04-11-10 Brad Ferrier - Removed cloud fraction algorithm -! 04-11-17 H CHUANG - WRF VERSION -! 14-03-11 B Ferrier - Created new & old versions of this subroutine -! to process new & old versions of the microphysics -! -! USAGE: CALL CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL -! &, QW1,QI1,QR1,QS1,DBZ1,DBZR1,DBZI1,DBZC1) -! -! INPUT ARGUMENT LIST: -! P1D - PRESSURE (PA) -! T1D - TEMPERATURE (K) -! Q1D - SPECIFIC HUMIDITY (KG/KG) -! C1D - TOTAL CONDENSATE (CWM, KG/KG) -! FI1D - F_ice (fraction of condensate in form of ice) -! FR1D - F_rain (fraction of liquid water in form of rain) -! FS1D - F_RimeF ("Rime Factor", ratio of total ice growth -! to deposition growth) -! CUREFL - Radar reflectivity contribution from convection (mm**6/m**3) -! -! OUTPUT ARGUMENT LIST: -! QW1 - CLOUD WATER MIXING RATIO (KG/KG) -! QI1 - CLOUD ICE MIXING RATIO (KG/KG) -! QR1 - RAIN MIXING RATIO (KG/KG) -! QS1 - "SNOW" (precipitation ice) MIXING RATIO (KG/KG) -! DBZ1 - Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z) -! DBZR - Equivalent radar reflectivity factor from rain in dBZ -! DBZI - Equivalent radar reflectivity factor from ice (all forms) in dBZ -! DBZC - Equivalent radar reflectivity factor from parameterized convection -! in dBZ -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! FUNCTIONS: -! FPVS -! UTILITIES: -! LIBRARY: -! NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : IBM SP -!$$$ -! +!> CALMICT_old computes hydrometeors from the older version of the microphysics. +!> +!> This routin computes the mixing ratios of cloud water, cloud ice, +!> rain, and snow. The code is based on option MP_PHYSICS==95 in the +!> WRF namelist and option MICRO='fer' in NMMB configure files. +!> +!> @param[in] P1D Pressure (Pa). +!> @param[in] T1D Temperature (K). +!> @param[in] Q1D Specific humidity (kg/kg). +!> @param[in] C1D Total condensate (CWM, kg/kg). +!> @param[in] FI1D F_ice (fraction of condensate in form of ice). +!> @param[in] FR1D F_rain (fraction of liquid water in form of rain). +!> @param[in] FS1D F_RimeF ("Rime Factor", ratio of total ice growth to deposition growth). +!> @param[in] CUREFL Radar reflectivity contribution from convection (mm**6/m**3). +!> @param[out] QW1 Cloud water mixing ratio (kg/kg). +!> @param[out] QI1 Cloud ice mixing ratio (kg/kg). +!> @param[out] QR1 Rain mixing ratio (kg/kg). +!> @param[out] QS1 "Snow" (precipitation ice) mixing ratio (kg/kg). +!> @param[out] DBZ1 Equivalent radar reflectivity factor in dBZ; i.e., 10*LOG10(Z). +!> @param[out] DBZR Equivalent radar reflectivity factor from rain in dBZ. +!> @param[out] DBZI Equivalent radar reflectivity factor from ice (all forms) in dBZ. +!> @param[out] DBZC Equivalent radar reflectivity factor from parameterized convection in dBZ. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2001-08-14 | Yi Jin | Initial +!> 2002-02-11 | Brad Ferrier | Minor changes for consistency w/ NMM model +!> 2004-11-10 | Brad Ferrier | Removed cloud fraction algorithm +!> 2004-11-17 | H Chuang | WRF VERSION +!> 2014-03-11 | Brad Ferrier | Created new & old versions of this subroutine to process new & old versions of the microphysics +!> +!> @author Yi Jin W/NP2 @date 2001-08-14 use params_mod, only: dbzmin, epsq, tfrz, eps, rd, d608, oneps, nlimin - use ctlblk_mod, only: jsta, jend, jsta_2l, jend_2u, im + use ctlblk_mod, only: jsta, jend, jsta_2l, jend_2u, im, & + ista, iend, ista_2l, iend_2u use rhgrd_mod, only: rhgrd use cmassi_mod, only: t_ice, rqr_drmin, n0rmin, cn0r_dmrmin, mdrmin, & rqr_drmax,cn0r_dmrmax, mdrmax, n0r0, xmrmin, xmrmax,flarge2, & @@ -392,9 +347,9 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & INTEGER INDEXS, INDEXR REAL, PARAMETER :: Cice=1.634e13 - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: P1D,T1D,Q1D,C1D,FI1D,FR1D, & FS1D,CUREFL - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: QW1,QI1,QR1,QS1,DBZ1,DBZR1,& DBZI1,DBZC1,NLICE1,NRAIN1 REAL N0r,Ztot,Zrain,Zice,Zconv,Zmin @@ -409,7 +364,7 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! Zmin=10.**(0.1*DBZmin) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QW1(I,J)=0. QI1(I,J)=0. QR1(I,J)=0. @@ -423,7 +378,7 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ENDDO ENDDO DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Zrain=0. !--- Radar reflectivity from rain Zice=0. !--- Radar reflectivity from ice Zconv=CUREFL(I,J) !--- Radar reflectivity from convection diff --git a/sorc/ncep_post.fd/CALPBL.f b/sorc/ncep_post.fd/CALPBL.f index d71f9676a..015f4cd10 100644 --- a/sorc/ncep_post.fd/CALPBL.f +++ b/sorc/ncep_post.fd/CALPBL.f @@ -1,34 +1,18 @@ !> @file -! -!> SUBPROGRAM: CALPBL COMPUTES PBL HEIGHT BASED ON BULK RCH NUMBER -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE BULK RICHARDSON NUMBER -!! AND PBL HEIGHT ABOVE SURFACE -!! -!! PROGRAM HISTORY LOG: -!! 06-05-04 M TSIDULKO -!! -!! USAGE: CALL CALPBL(PBLRI) -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! PBLRI - PBL HEIGHT ABOVE GROUND -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : -!! +!> @brief Subroutine that computes PBL height based on bulk RCH number. +!> +!> This routine computes the bulk Richardson number +!> and PBL height above surface. +!> +!> @param[out] PBLRI PBL height above ground. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2006-05-04 | M Tsidulko | Initial +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author M Tsidulko @date 2006-05-04 SUBROUTINE CALPBL(PBLRI) ! @@ -36,22 +20,23 @@ SUBROUTINE CALPBL(PBLRI) use vrbls2d, only: fis use masks, only: vtm use params_mod, only: h10e5, capa, d608, h1, g, gi - use ctlblk_mod, only: lm, im, jsta, jend, spval, jsta_m, jsta_2l, jend_2u, jend_m + use ctlblk_mod, only: lm, im, jsta, jend, spval, jsta_m, jsta_2l, jend_2u, jend_m, & + ista, iend, ista_m, ista_2l, iend_2u, iend_m use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: PBLRI + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: PBLRI REAL, ALLOCATABLE :: THV(:,:,:) - INTEGER IFRSTLEV(IM,jsta_2l:jend_2u),ICALPBL(IM,jsta_2l:jend_2u) & - ,LVLP(IM,jsta_2l:jend_2u) - REAL RIF(IM,jsta_2l:jend_2u) & - ,RIBP(IM,jsta_2l:jend_2u),UBOT1(IM,jsta_2l:jend_2u) & - ,VBOT1(IM,jsta_2l:jend_2u),ZBOT1(IM,jsta_2l:jend_2u) & - ,THVBOT1(IM,jsta_2l:jend_2u) + INTEGER IFRSTLEV(ista_2l:iend_2u,jsta_2l:jend_2u),ICALPBL(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,LVLP(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL RIF(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,RIBP(ista_2l:iend_2u,jsta_2l:jend_2u),UBOT1(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,VBOT1(ista_2l:iend_2u,jsta_2l:jend_2u),ZBOT1(ista_2l:iend_2u,jsta_2l:jend_2u) & + ,THVBOT1(ista_2l:iend_2u,jsta_2l:jend_2u) integer I,J,L,IE,IW real APE,BETTA,RICR,USTARR,WMIN,UHKL,ULKL,VHKL,VLKL,WNDSL,WNDSLP, & UBOT,VBOT,VTOP,UTOP,THVTOP,ZTOP,WDL2,RIB @@ -59,13 +44,13 @@ SUBROUTINE CALPBL(PBLRI) !************************************************************************* ! START CALRCHB HERE. ! - ALLOCATE ( THV(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( THV(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! INITIALIZE ARRAYS. ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PBLRI(I,J) = SPVAL ENDDO ENDDO @@ -75,7 +60,7 @@ SUBROUTINE CALPBL(PBLRI) !$omp parallel do private(i,j,l,ape) DO L=LM,1,-1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if( PMID(I,J,L) @file -! . . . -!> SUBPROGRAM: CALPBL COMPUTES PBL HEIGHT BASED ON BULK RCH NUMBER -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE BULK RICHARDSON NUMBER BASED ON ALGORITHMS -!! FROM WRF SURFACE LAYER AND THEN DERIVE PBL REGIME AS FOLLOWS: -!! 1. BR >= 0.2; -!! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), -!! -!! 2. BR < 0.2 .AND. BR > 0.0; -!! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS -!! (REGIME=2), -!! -!! 3. BR == 0.0 -!! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), -!! -!! 4. BR < 0.0 -!! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). -!! . -!! -!! PROGRAM HISTORY LOG: -!! 07-04-27 H CHUANG -!! -!! USAGE: CALL CALPBLREGIME(PBLREGIME) -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! PBLRI - PBL HEIGHT ABOVE GROUND -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : -!! +!> @brief Subroutine that computes PBL height based on bulk RCH number. +!> +!> This routine computes the bulk Richardson number based on algorithms +!> from WRF surface layer and then derive PBL regime as follows: +!> 1. BR >= 0.2; +!> Represents nighttime stable conditions (Regime=1), +!> +!> 2. BR < 0.2 .AND. BR > 0.0; +!> Represents damped mechanical turbulent conditions +!> (Regime=2), +!> +!> 3. BR == 0.0 +!> Represents forced convection conditions (Regime=3), +!> +!> 4. BR < 0.0 +!> Represnets free convection conditions (Regime=4). +!> +!> @param[out] PBLRI PBL Height above ground. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-04-27 | H Chuang | Initial +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author H Chuang @date 2007-04-27 SUBROUTINE CALPBLREGIME(PBLREGIME) ! @@ -50,7 +33,7 @@ SUBROUTINE CALPBLREGIME(PBLREGIME) use masks, only: dx use params_mod, only: p1000, capa, d608, h1, g, rd, cp use ctlblk_mod, only: jsta, jend, spval, lm, jsta_m, jend_m, im, & - jsta_2l, jend_2u + jsta_2l, jend_2u, ista, iend, ista_m, iend_m,ista_2l,iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -61,7 +44,7 @@ SUBROUTINE CALPBLREGIME(PBLREGIME) ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta_2l:jend_2u),intent(inout) :: PBLREGIME + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: PBLREGIME ! integer I,J,IE,IW,ii,jj real APE,THV,THVX,GOVRTH,UMASS,VMASS,WSPD,TSKV,DTHV,RHOX,fluxc,tsfc, & @@ -75,7 +58,7 @@ SUBROUTINE CALPBLREGIME(PBLREGIME) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PBLREGIME(I,J) = SPVAL ENDDO ENDDO @@ -102,7 +85,7 @@ SUBROUTINE CALPBLREGIME(PBLREGIME) END IF DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! IF(PMID(I,J,LM) @file -! -!> SUBPROGRAM: CALPOT COMPUTES POTENTIAL TEMPERATURE -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-24 -!! -!! ABSTRACT: -!! GIVEN PRESSURE AND TEMPERATURE THIS ROUTINE RETURNS -!! THE POTENTIAL TEMPERATURE. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-24 RUSS TREADON -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! -!! USAGE: CALL CALPOT(P1D,T1D,THETA) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! T1D - TEMPERATURE (K) -!! -!! OUTPUT ARGUMENT LIST: -!! THETA - POTENTIAL TEMPERATURE (K) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes potential temperature. +!> +!> Given pressure and temperature this routine returns +!> the potential temperature. +!> +!> @param[in] P1D pressures (Pa). +!> @param[in] T1D temperatures (K). +!> @param[out] THETA potential temperatures (K). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-24 | Russ Treadon | Initial +!> 1998-06-15 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1992-12-24 SUBROUTINE CALPOT(P1D,T1D,THETA) ! - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: jsta, jend, spval, im, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -46,8 +30,8 @@ SUBROUTINE CALPOT(P1D,T1D,THETA) ! ! DECLARE VARIABLES. ! - real,dimension(IM,jsta:jend),intent(in) :: P1D,T1D - real,dimension(IM,jsta:jend),intent(inout) :: THETA + real,dimension(ista:iend,jsta:jend),intent(in) :: P1D,T1D + real,dimension(ista:iend,jsta:jend),intent(inout) :: THETA integer I,J ! @@ -58,7 +42,7 @@ SUBROUTINE CALPOT(P1D,T1D,THETA) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < SPVAL) THEN ! IF(ABS(P1D(I,J)) > 1.0) THEN IF(P1D(I,J) > 1.0) THEN diff --git a/sorc/ncep_post.fd/CALPW.f b/sorc/ncep_post.fd/CALPW.f index 2944454c0..dced136ca 100644 --- a/sorc/ncep_post.fd/CALPW.f +++ b/sorc/ncep_post.fd/CALPW.f @@ -1,61 +1,43 @@ !> @file -! . . . -!> SUBPROGRAM: CALPW COMPUTES -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-24 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES PRECIPITABLE WATER IN A COLUMN -!! EXTENDING FROM THE FIRST ATMOSPHERIC ETA LAYER TO THE -!! MODEL TOP. THE DEFINITION USED IS -!! TOP -!! PRECIPITABLE WATER = SUM (Q+CLDW) DP*HTM/G -!! BOT -!! WHERE, -!! BOT IS THE FIRST ETA LAYER, -!! TOP IS THE MODEL TOP, -!! Q IS THE SPECIFIC HUMIDITY (KG/KG) IN THE LAYER -!! CLDW IS THE CLOUD WATER (KG/KG) IN THE LAYER -!! DP (Pa) IS THE LAYER THICKNESS. -!! HTM IS THE HEIGHT MASK AT THAT LAYER (=0 IF BELOW GROUND) -!! G IS THE GRAVITATIONAL CONSTANT -!! -!! PROGRAM HISTORY LOG: -!! 92-12-24 RUSS TREADON -!! 96-03-04 MIKE BALDWIN - ADD CLOUD WATER AND SPEED UP CODE -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! 04-12-30 H CHUANG - UPDATE TO CALCULATE TOTAL COLUMN FOR OTHER -!! HYDROMETEORS -!! 14-11-12 SARAH LU - UPDATE TO CALCULATE AEROSOL OPTICAL DEPTH -!! 15-07-02 SARAH LU - UPDATE TO CALCULATE SCATTERING AEROSOL -!! OPTICAL DEPTH (18) -!! 15-07-04 SARAH LU - CORRECT PW INTEGRATION FOR AOD (17) -!! 15-07-10 SARAH LU - UPDATE TO CALCULATE ASYMETRY PARAMETER -!! 19-07-25 Li(Kate) Zhang - MERGE SARHA LU's update for FV3-Chem -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! -!! USAGE: CALL CALPW(PW) -!! INPUT ARGUMENT LIST: -!! PW - ARRAY OF PRECIPITABLE WATER. -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - LOOPS -!! MASKS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes precipitable water. +!> +!>
+!> This routine computes precipitable water in a column
+!> extending from the first atmospheric ETA layer to the
+!> model top. The definition used is
+!>                      TOP
+!> precipitable water = sum (Q+CLDW) DP*HTM/G
+!>                      BOT
+!> where,
+!> BOT is the first ETA layer,
+!> TOP is the model top,
+!> Q is the specific humidity (kg/kg) in the layer
+!> CLDW is the cloud water (kg/kg) in the layer
+!> DP (Pa) is the layer thickness.
+!> HTM is the height mask at that layer (=0 if below ground)
+!> G is the gravitational constant.
+!>
+!> +!> @param[in] PW Array of precipitable water. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-24 | Russ Treadon | Initial +!> 1996-03-04 | Mike Baldwin | Add cloud water and speed up code +!> 1998-06-15 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-19 | Mike Baldwin | WRF Version +!> 2004-12-30 | H Chuang | Update to calculate total column for other hydrometeors +!> 2014-11-12 | Sarah Lu | Update tp calculate aerosol optical depth +!> 2015-07-02 | Sarah Lu | Update to calculate scattering aerosal optical depth (18) +!> 2015-07-04 | Sarah Lu | Correct PW integration for AOD (17) +!> 2015-07-10 | Sarah Lu | Update to calculate asymetry parameter +!> 2019-07-25 | Li(Kate) Zhang | Merge Sarah Lu's update for FV3-Chem +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1992-12-24 SUBROUTINE CALPW(PW,IDECID) ! @@ -65,7 +47,7 @@ SUBROUTINE CALPW(PW,IDECID) use vrbls4d, only: smoke use masks, only: htm use params_mod, only: tfrz, gi - use ctlblk_mod, only: lm, jsta, jend, im, spval + use ctlblk_mod, only: lm, jsta, jend, im, spval, ista, iend use upp_physics, only: FPVSNEW !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -82,10 +64,10 @@ SUBROUTINE CALPW(PW,IDECID) ! DECLARE VARIABLES. ! integer,intent(in) :: IDECID - real,dimension(IM,jsta:jend),intent(inout) :: PW + real,dimension(ista:iend,jsta:jend),intent(inout) :: PW INTEGER LLMH,I,J,L REAL ALPM,DZ,PM,PWSUM,RHOAIR,DP,ES - REAL QDUM(IM,jsta:jend), PWS(IM,jsta:jend),QS(IM,jsta:jend) + REAL QDUM(ista:iend,jsta:jend), PWS(ista:iend,jsta:jend),QS(ista:iend,jsta:jend) ! !*************************************************************** ! START CALPW HERE. @@ -94,7 +76,7 @@ SUBROUTINE CALPW(PW,IDECID) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PW(i,j) = 0. PWS(i,j) = 0. ENDDO @@ -108,42 +90,42 @@ SUBROUTINE CALPW(PW,IDECID) IF (IDECID <= 1) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = Q(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 2) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQW(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 3) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQI(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 4) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQR(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 5) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQS(I,J,L) ENDDO ENDDO ELSE IF (IDECID == 6) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = CWM(I,J,L) ENDDO ENDDO @@ -151,7 +133,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 16) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = QQG(I,J,L) ENDDO ENDDO @@ -160,7 +142,7 @@ SUBROUTINE CALPW(PW,IDECID) !-- Total supercooled liquid !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T(I,J,L) >= TFRZ) THEN Qdum(I,J) = 0. ELSE @@ -172,7 +154,7 @@ SUBROUTINE CALPW(PW,IDECID) !-- Total melting ice !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T(I,J,L) <= TFRZ) THEN Qdum(I,J) = 0. ELSE @@ -184,7 +166,7 @@ SUBROUTINE CALPW(PW,IDECID) ! SHORT WAVE T TENDENCY !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = RSWTT(I,J,L) ENDDO ENDDO @@ -192,7 +174,7 @@ SUBROUTINE CALPW(PW,IDECID) ! LONG WAVE T TENDENCY !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = RLWTT(I,J,L) ENDDO ENDDO @@ -200,7 +182,7 @@ SUBROUTINE CALPW(PW,IDECID) ! LATENT HEATING FROM GRID SCALE RAIN/EVAP !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = TRAIN(I,J,L) ENDDO ENDDO @@ -208,7 +190,7 @@ SUBROUTINE CALPW(PW,IDECID) ! LATENT HEATING FROM CONVECTION !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = TCUCN(I,J,L) ENDDO ENDDO @@ -216,7 +198,7 @@ SUBROUTINE CALPW(PW,IDECID) ! MOISTURE CONVERGENCE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = MCVG(I,J,L) ENDDO ENDDO @@ -224,7 +206,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 14) THEN !$omp parallel do private(i,j,es) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = Q(I,J,L) ES = min(FPVSNEW(T(I,J,L)),PMID(I,J,L)) QS(I,J) = CON_EPS*ES/(PMID(I,J,L)+CON_EPSM1*ES) @@ -234,7 +216,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 15) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = O3(I,J,L) ENDDO END DO @@ -243,7 +225,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 17) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = EXT(I,J,L) ENDDO END DO @@ -253,7 +235,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 18) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = SMOKE(I,J,L,1)/1000000000. ENDDO END DO @@ -263,7 +245,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 19) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = TAOD5503D(I,J,L) ENDDO END DO @@ -272,7 +254,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 20) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = SCA(I,J,L) ENDDO END DO @@ -281,7 +263,7 @@ SUBROUTINE CALPW(PW,IDECID) ELSE IF (IDECID == 21) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Qdum(I,J) = ASY(I,J,L) ENDDO END DO @@ -289,15 +271,13 @@ SUBROUTINE CALPW(PW,IDECID) ! !$omp parallel do private(i,j,dp) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(PINT(I,J,L+1) @file -! -!> THIS ROUTINE COMPUTES MODEL DERIVED BRIGHTNESS TEMPERATURE -!! USING CRTM. IT IS PATTERNED AFTER GSI SETUPRAD WITH TREADON'S HELP -!! -!! PROGRAM HISTORY LOG: -!! - 11-02-06 Jun WANG - addgrib2 option -!! - 14-12-09 WM LEWIS ADDED: -!! FUNCTION EFFR TO COMPUTE EFFECTIVE PARTICLE RADII -!! CHANNEL SELECTION USING LVLS FROM WRF_CNTRL.PARM -!! - 19-04-01 Sharon NEBUDA - Added output option for GOES-16 & GOES-17 ABI IR Channels 7-16 -!! - 20-04-09 Tracy Hertneky - Added Himawari-8 AHI CH7-CH16 -!! - 21-01-10 Web Meng - Added checking points for skiping grids with filling value spval -!! - 21-03-11 Bo Cui - improve local arrays memory -!! - 21-08-31 Lin Zhu - added ssmis-f17 channels 15-18 grib2 output -!! - 22-05-26 Wm Lewis added support for GOES-18 ABI IR Channels 7-16 -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! /nwprod/lib/sorc/crtm2 -!! -!! @author CHUANG @date 07-01-17 -!! +!> @brief Subroutine that computes model derived brightness temperature. +!> +!> This routine computes model derived brightness temperature +!> using CRTM. It is patterned after GSI setuprad with Treadon's help. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-01-17 | H Chuang | Initial +!> 2011-02-06 | Jun Wang | add grib2 option +!> 2014-12-09 | WM Lewis | added function EFFR to compute effective particle radii channel selection using LVLS from WRF_CNTRL.PARM +!> 2019-04-01 | Sharon Nebuda | Added output option for GOES-16 & GOES-17 ABI IR Channels 7-16 +!> 2020-04-09 | Tracy Hertneky | Added Himawari-8 AHI CH7-CH16 +!> 2021-01-10 | Wen Meng | Added checking points for skiping grids with filling value spval +!> 2021-03-11 | Bo Cui | improve local arrays memory +!> 2021-08-31 | Lin Zhu | added ssmis-f17 channels 15-18 grib2 output +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> 2022-05-26 | Wm Lewis | added support for GOES-18 ABI IR Channels 7-16 +!> +!> @author Chuang @date 2007-01-17 SUBROUTINE CALRAD_WCLOUD use vrbls3d, only: o3, pint, pmid, t, q, qqw, qqi, qqr, f_rimef, nlice, nrain, qqs, qqg, & @@ -59,7 +52,7 @@ SUBROUTINE CALRAD_WCLOUD use params_mod, only: pi, rtd, p1000, capa, h1000, h1, g, rd, d608, qconv, small use rqstfld_mod, only: iget, id, lvls, iavblfld use ctlblk_mod, only: modelname, ivegsrc, novegtype, imp_physics, lm, spval, icu_physics,& - grib, cfld, fld_info, datapd, idat, im, jsta, jend, jm, me + grib, cfld, fld_info, datapd, idat, im, jsta, jend, jm, me, ista, iend ! implicit none @@ -186,7 +179,7 @@ SUBROUTINE CALRAD_WCLOUD real(r_kind) snodepth,vegcover real snoeqv real snofrac - real(r_kind),dimension(im,jsta:jend):: tb1,tb2,tb3,tb4 + real(r_kind),dimension(ista:iend,jsta:jend):: tb1,tb2,tb3,tb4 real(r_kind),allocatable :: tb(:,:,:) real,dimension(im,jm):: grid1 real sun_zenith,sun_azimuth, dpovg, sun_zenith_rad @@ -344,8 +337,8 @@ SUBROUTINE CALRAD_WCLOUD .or. iget(874) > 0 .or. iget(875) > 0 .or. iget(876) > 0 & .or. iget(877) > 0 .or. iget(878) > 0 .or. iget(879) > 0 & .or. iget(880) > 0 .or. iget(881) > 0 .or. iget(882) > 0 & - .or. post_ahi8 .or. post_ssmis17 & - .or. post_abig16 .or. post_abig17 .or. post_abig18 & + .or. post_ahi8 .or. post_ssmis17 & + .or. post_abig16 .or. post_abig17 .or. post_abig18 & .or. post_abigr ) then ! specify numbers of cloud species @@ -373,7 +366,7 @@ SUBROUTINE CALRAD_WCLOUD ! if (MODELNAME == 'GFS')then jdn=iw3jdn(idat(3),idat(1),idat(2)) do j=jsta,jend - do i=1,im + do i=ista,iend call zensun(jdn,float(idat(4)),gdlat(i,j),gdlon(i,j) & ,pi,sun_zenith,sun_azimuth) sun_zenith_rad=sun_zenith/rtd @@ -658,7 +651,7 @@ SUBROUTINE CALRAD_WCLOUD if(isis=='abi_gr')channelinfo(sensorindex)%WMO_Sensor_Id=617 allocate(rtsolution (channelinfo(sensorindex)%n_channels,1)) - allocate(tb(im,jsta:jend,channelinfo(sensorindex)%n_channels)) + allocate(tb(ista:iend,jsta:jend,channelinfo(sensorindex)%n_channels)) err1=0; err2=0; err3=0; err4=0 if(lm > max_n_layers)then write(6,*) 'CALRAD: lm > max_n_layers - '// & @@ -741,7 +734,7 @@ SUBROUTINE CALRAD_WCLOUD (isis=='abi_gr' .and. post_abigr) )then do j=jsta,jend - loopi1:do i=1,im + loopi1:do i=ista,iend ! Skiping the grids with filling value spval do k=1,lm @@ -1181,14 +1174,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(482+ixchan) if(igot>0) then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1199,14 +1192,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(487+ixchan) if(igot>0) then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j) = tb(i,j,ichan) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1218,14 +1211,14 @@ SUBROUTINE CALRAD_WCLOUD igot=445+ixchan if(igot>0) then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j) = tb(i,j,ichan) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif ! IGOT enddo @@ -1237,14 +1230,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(326+ixchan) if(igot>0) then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1256,14 +1249,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(957+ixchan) if(igot>0)then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo ! channel loop @@ -1298,7 +1291,7 @@ SUBROUTINE CALRAD_WCLOUD iget(461)>0 .or. iget(462)>0 .or. iget(463)>0)))then do j=jsta,jend - loopi2:do i=1,im + loopi2:do i=ista,iend ! Skiping the grids with filling value spval do k=1,lm @@ -1763,14 +1756,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1785,14 +1778,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1807,14 +1800,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1830,14 +1823,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1849,14 +1842,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(824+ixchan) if(igot>0)then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1870,14 +1863,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1892,14 +1885,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1914,14 +1907,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -1934,14 +1927,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ichan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1953,14 +1946,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ichan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1972,14 +1965,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ichan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -1990,14 +1983,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(459+ixchan) if(igot>0) then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -2008,14 +2001,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(455+ixchan) if(igot>0) then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo @@ -2029,14 +2022,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -2051,14 +2044,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -2073,14 +2066,14 @@ SUBROUTINE CALRAD_WCLOUD if(lvls(ixchan,igot)==1)then nc=nc+1 do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,nc) enddo enddo if (grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif endif @@ -2093,14 +2086,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(926+ixchan) if(igot>0)then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo ! channel loop @@ -2112,14 +2105,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(936+ixchan) if(igot>0)then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo ! channel loop @@ -2153,14 +2146,14 @@ SUBROUTINE CALRAD_WCLOUD igot=iget(968+ichan) if(igot>0)then do j=jsta,jend - do i=1,im + do i=ista,iend grid1(i,j)=tb(i,j,ichan) enddo enddo if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(igot) - datapd(1:im,1:jend-jsta+1,cfld)=grid1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend) endif endif enddo diff --git a/sorc/ncep_post.fd/CALRCH.f b/sorc/ncep_post.fd/CALRCH.f index 60b5425b6..b1b520aed 100644 --- a/sorc/ncep_post.fd/CALRCH.f +++ b/sorc/ncep_post.fd/CALRCH.f @@ -1,43 +1,26 @@ !> @file -! -!> SUBPROGRAM: CALRCH COMPUTES GRD RCH NUMBER -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-10-11 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE GRADIENT RICHARDSON NUMBER -!! AS CODED IN ETA MODEL SUBROUTINE PROFQ2.F. -!! FIX TO AVOID UNREASONABLY SMALL ANEMOMETER LEVEL WINDS. -!! -!! PROGRAM HISTORY LOG: -!! 93-10-11 RUSS TREADON -!! 98-06-17 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 05-02-25 H CHUANG - ADD COMPUTATION FOR NMM E GRID -!! 05-07-07 BINBIN ZHOU - ADD RSM FOR A GRID -!! -!! USAGE: CALL CALRCH(EL,RICHNO) -!! INPUT ARGUMENT LIST: -!! EL - MIXING LENGTH SCALE. -!! -!! OUTPUT ARGUMENT LIST: -!! RICHNO - GRADIENT RICHARDSON NUMBER. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes GRD RCH number. +!> +!> This routine computes the gradient Richardson number +!> as coded in ETA model subroutine PROFQ2.F. +!> Fix to avoid unreasonably small anemometer level winds. +!> +!> @param[in] EL Mixing length scale. +!> @param[out] RICHNO Gradient Richardson number. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-10-11 | Russ Treadon | Initial +!> 1998-06-17 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2001-10-22 | H Chuang | Modified to process hybrid model output +!> 2002-01-15 | Mike Baldwin | WRF Version +!> 2005-02-25 | H Chuang | Add computation for NMM E grid +!> 2005-07-07 | Binbin Zhou | Add RSM for A Grid +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-10-11 SUBROUTINE CALRCH(EL,RICHNO) ! @@ -45,15 +28,16 @@ SUBROUTINE CALRCH(EL,RICHNO) use masks, only: vtm use params_mod, only: h10e5, capa, d608,h1, epsq2, g, beta use ctlblk_mod, only: jsta, jend, spval, lm1, jsta_m, jend_m, im, & - jsta_2l, jend_2u, lm + jsta_2l, jend_2u, lm, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL,intent(in) :: EL(IM,jsta_2l:jend_2u,LM) - REAL,intent(inout) :: RICHNO(IM,jsta_2l:jend_2u,LM) + REAL,intent(in) :: EL(ista_2l:iend_2u,jsta_2l:jend_2u,LM) + REAL,intent(inout) :: RICHNO(ista_2l:iend_2u,jsta_2l:jend_2u,LM) ! REAL, ALLOCATABLE :: THV(:,:,:) integer I,J,L,IW,IE @@ -66,13 +50,13 @@ SUBROUTINE CALRCH(EL,RICHNO) !************************************************************************* ! START CALRCH HERE. ! - ALLOCATE ( THV(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( THV(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! INITIALIZE ARRAYS. ! !$omp parallel do DO L = 1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND RICHNO(I,J,L)=SPVAL ENDDO ENDDO @@ -83,7 +67,7 @@ SUBROUTINE CALRCH(EL,RICHNO) !$omp parallel do private(i,j,ape) DO L=LM,1,-1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND APE = (H10E5/PMID(I,J,L))**CAPA THV(I,J,L) = (Q(I,J,L)*D608+H1)*T(I,J,L)*APE ENDDO @@ -108,7 +92,7 @@ SUBROUTINE CALRCH(EL,RICHNO) end if DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! IF(GRIDTYPE == 'A')THEN UHKL = UH(I,J,L) diff --git a/sorc/ncep_post.fd/CALSTRM.f b/sorc/ncep_post.fd/CALSTRM.f index c9204ccb6..adf7ac43e 100644 --- a/sorc/ncep_post.fd/CALSTRM.f +++ b/sorc/ncep_post.fd/CALSTRM.f @@ -1,43 +1,27 @@ !> @file -! -!> SUBPROGRAM: CALSTRM COMPUTES GEO STREAMFUNCTION -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE GEOSTROPHIC STREAMFUNCTION, -!! PSI, FROM THE PASSED GEOPOTENTIAL HEIGHT FIELD, Z. -!! THE FORMULA USED IS PSI = G*Z/F0, WHERE G IS THE -!! GRAVITATIONAL ACCELERATION CONSTANT AND F0 IS A -!! CONSTANT CORIOLIS PARAMETER. F0 IS SET TO BE THE -!! VALUE OF THE CORIOLIS PARAMETER NEAR THE CENTER -!! OF THE MODEL GRID. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-05 JIM TUCCILLO - MPI VERSION -!! 02-06-13 MIKE BALDWIN - WRF VERSION -!! -!! USAGE: CALL CALSTRM(Z1D,STRM) -!! INPUT ARGUMENT LIST: -!! Z1D - GEOPOTENTIAL HEIGHT (M) -!! -!! OUTPUT ARGUMENT LIST: -!! STRM - GEOSTROPHIC STREAMFUNCTION -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - MAPOT -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes geo streamfunction. +!> +!> This routine computes the geostrophic streamfunction, +!> PSI, from the passed geopotential height field, Z. +!> The formule used it PSI = G*Z/F0, where G is the +!> gravitational acceleration constant and F0 is a +!> constant Coriolis parameter. F0 is set to be the +!> valus of the Coriolis parameter near the center +!> of the model grid. +!> +!> @param[in] Z1D Geopotential height (m). +!> @param[out] STRM Geostrophic streamfunction. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1998-06-08 | T Black | Conversion from 1-D TO 2-D +!> 2000-01-05 | Jim Tuccillo | MPI Version +!> 2002-06-13 | Mike Baldwin | WRF Version +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE CALSTRM(Z1D,STRM) ! @@ -48,7 +32,7 @@ SUBROUTINE CALSTRM(Z1D,STRM) ! ! use vrbls2d, only: use params_mod, only: g - use ctlblk_mod, only: jsta, jend, im + use ctlblk_mod, only: jsta, jend, im, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -57,8 +41,8 @@ SUBROUTINE CALSTRM(Z1D,STRM) ! DECLARE VARIABLES. ! ! LOGICAL FIRST,OLDRD,RESTRT,RUN,SIGMA,STRD - REAL, dimension(im,jsta:jend), intent(in) :: Z1D - REAL, dimension(im,jsta:jend), intent(inout) :: STRM + REAL, dimension(ista:iend,jsta:jend), intent(in) :: Z1D + REAL, dimension(ista:iend,jsta:jend), intent(inout) :: STRM ! LOGICAL OLDRD,STRD integer IMID,I,J @@ -76,7 +60,7 @@ SUBROUTINE CALSTRM(Z1D,STRM) ! COMPUTE GEOSTROPHIC STREAMFUNCTION. !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND STRM(I,J) = GOF0*Z1D(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/CALTAU.f b/sorc/ncep_post.fd/CALTAU.f index 79bae45d3..08338039d 100644 --- a/sorc/ncep_post.fd/CALTAU.f +++ b/sorc/ncep_post.fd/CALTAU.f @@ -1,46 +1,30 @@ !> @file -! -!> SUBPROGRAM: CALTAU COMPUTE U AND V WIND STRESSES -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-09-01 -!! -!! ABSTRACT: THIS ROUTINE COMPUTES SURFACE LAYER U AND V -!! WIND COMPONENT STRESSES USING K THEORY AS PRESENTED -!! IN SECTION 8.4 OF "NUMBERICAL PREDICTION AND DYNAMIC -!! METEOROLOGY" BY HALTINER AND WILLIAMS (1980, JOHN WILEY -!! & SONS). -!! -!! PROGRAM HISTORY LOG: -!! 93-09-01 RUSS TREADON -!! 98-06-11 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION, OUTPUT IS ON MASS-POINTS -!! 05-02-23 H CHUANG - COMPUTE STRESS FOR NMM ON WIND POINTS -!! 05-07-07 BINBIN ZHOU - ADD RSM STRESS for A GRID -!! 21-07-26 W Meng - Restrict computation from undefined grids -!! USAGE: CALL CALTAU(TAUX,TAUY) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! TAUX - SUFACE LAYER U COMPONENT WIND STRESS. -!! TAUY - SUFACE LAYER V COMPONENT WIND STRESS. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! CLMAX -!! MIXLEN -!! -!! LIBRARY: -!! COMMON - -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes U and V wind stresses. +!> +!> This routine computes surface layer U and V +!> wind component stresses using K theory as presented +!> in section 8.4 of "Numerical prediction and dynamic +!> meteorology" by Haltiner and Williams (1980, John Wiley +!> & Sons). +!> +!> @param[out] TAUX Suface layer U component wind stress. +!> @param[out] TAUY Suface layer V component wind stress. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-09-01 | Russ Treadon | Initial +!> 1998-06-11 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2001-10-25 | H Chuang | Modified to process hybrid output +!> 2002-01-15 | Mike Baldwin | WRF Version, output is on mass-points +!> 2005-02-23 | H Chuang | Compute stress for NMM on wind points +!> 2005-07-07 | Binbin Zhou | Add RSM stress for A Grid +!> 2021-07-26 | W Meng | Restrict computation from undefined grids +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-09-01 + SUBROUTINE CALTAU(TAUX,TAUY) ! @@ -50,7 +34,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) use masks, only: lmh use params_mod, only: d00, d50, h1, d608, rd, d25 use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, spval, jsta_m,& - jm, im, jend_m + jm, im, jend_m, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none @@ -58,9 +42,9 @@ SUBROUTINE CALTAU(TAUX,TAUY) ! DECLARE VARIABLES. INTEGER, dimension(4) :: KK(4) INTEGER, dimension(jm) :: ive, ivw - REAL, dimension(im,jsta:jend), intent(inout) :: TAUX, TAUY + REAL, dimension(ista:iend,jsta:jend), intent(inout) :: TAUX, TAUY REAL, ALLOCATABLE :: EL(:,:,:) - REAL, dimension(im,jsta:jend) :: EGRIDU,EGRIDV,EGRID4,EGRID5, EL0 + REAL, dimension(ista:iend,jsta:jend) :: EGRIDU,EGRIDV,EGRID4,EGRID5, EL0 REAL UZ0V,VZ0V CHARACTER*1 AGRID integer I,J,LMHK,IE,IW,ii,jj @@ -70,7 +54,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) !******************************************************************** ! START CALTAU HERE. ! - ALLOCATE (EL(IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE (EL(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) ! ! COMPUTE MASTER LENGTH SCALE. ! @@ -80,7 +64,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) ! INITIALIZE OUTPUT AND WORK ARRAY TO ZERO. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRIDU(I,J) = D00 EGRIDV(I,J) = D00 TAUX(I,J) = SPVAL @@ -97,7 +81,7 @@ SUBROUTINE CALTAU(TAUX,TAUY) CALL MIXLEN(EL0,EL) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! LMHK = NINT(LMH(I,J)) IF(EL(I,J,LMHK-1) @file -! -!> SUBPROGRAM: CALTHTE COMPUTES THETA-E -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-06-18 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE EQUIVALENT POTENTIAL TEMPERATURE -!! GIVEN PRESSURE, TEMPERATURE, AND SPECIFIC HUMIDITY. THE -!! EQUATIONS OF BOLTON (MWR,1980) ARE USED. -!! -!! PROGRAM HISTORY LOG: -!! 93-06-18 RUSS TREADON -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 21-07-28 W Meng - Restrict computation from undefined grids -!! -!! USAGE: CALL CALTHTE(P1D,T1D,Q1D,THTE) -!! INPUT ARGUMENT LIST: -!! P1D - PRESSURE (PA) -!! T1D - TEMPERATURE (K) -!! Q1D - SPECIFIC HUMIDITY (KG/KG) -!! -!! OUTPUT ARGUMENT LIST: -!! THTE - THETA-E (K) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! VAPOR - FUNCTION TO CALCULATE VAPOR PRESSURE. -!! LIBRARY: -!! NONE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes Theta-E. +!> +!> This routine computes the equivalent potential temperature +!> given pressure, temperature, and specific humidity. The +!> equations of Bolton (MWR,1980) are used. +!> +!> @param[in] P1D pressure (Pa). +!> @param[in] T1D temperature (K). +!> @param[in] Q1D specific humidity(kg/kg). +!> @param[out] THTE Theta-E (K). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-06-18 | Russ Treadon | Initial +!> 1998-06-16 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2021-07-28 | W Meng | Restrict computation from undefined grids +!> 2021-09-02 | Bo Cui | Decompose UPP in X direction +!> +!> @author Russ Treadon W/NP2 @date 1993-06-18 + SUBROUTINE CALTHTE(P1D,T1D,Q1D,THTE) ! ! use params_mod, only: d00, eps, oneps, d01, h1m12, p1000, h1 - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: jsta, jend, im, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -53,8 +38,8 @@ SUBROUTINE CALTHTE(P1D,T1D,Q1D,THTE) ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta:jend),intent(in) :: P1D,T1D,Q1D - REAL,dimension(IM,jsta:jend),intent(inout) :: THTE + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1D,T1D,Q1D + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: THTE integer I,J real P,T,Q,EVP,RMX,CKAPA,RKAPA,ARG,DENOM,TLCL,PLCL,FAC, & @@ -66,7 +51,7 @@ SUBROUTINE CALTHTE(P1D,T1D,Q1D,THTE) ! ZERO THETA-E ARRAY !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND THTE(I,J) = D00 ENDDO ENDDO @@ -74,10 +59,10 @@ SUBROUTINE CALTHTE(P1D,T1D,Q1D,THTE) ! COMPUTE THETA-E. ! ! DO J=JSTA_M,JEND_M -! DO I=2,IM-1 +! DO I=ISTA_M,IEND_M !$omp parallel do private(i,j,p,t,q,evp,rmx,ckapa,rkapa,arg,denom,tlcl,plcl,fac,eterm,thetae) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(P1D(I,J) @file -! -!> SUBPROGRAM: CALUPDHEL COMPUTES UPDRAFT HELICITY -!! PRGRMMR: PYLE ORG: W/NP2 DATE: 07-10-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE UPDRAFT HELICITY -!! -!! PROGRAM HISTORY LOG: -!! 07-10-22 M PYLE - based on SPC Algorithm courtesy of David Bright -!! 11-01-11 M Pyle - converted to F90 for unified post -!! 11-04-05 H Chuang - added B grid option -!! 20-11-06 J Meng - USE UPP_MATH MODULE -!! -!! USAGE: CALL CALUPDHEL(UPDHEL) -!! -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! UPDHEL - UPDRAFT HELICITY (M^2/S^2) -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes the updraft helicity. +!> +!> @param[out] UPDHEL Updraft helicity (m^2/s^2). +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-10-22 | M Pyle | Initial +!> 2007-10-22 | M Pyle | based on SPC Algorithm courtesy of David Bright +!> 2011-01-11 | M Pyle | converted to F90 for unified post +!> 2011-04-05 | H Chuang | added B grid option +!> 2020-11-06 | J Meng | Use UPP_MATH Module +!> 2021-10-31 | J Meng | 2D DECOMPOSITION +!> +!> @author M Pyle W/NP2 @date 2007-10-22 SUBROUTINE CALUPDHEL(UPDHEL) ! @@ -42,7 +23,8 @@ SUBROUTINE CALUPDHEL(UPDHEL) use masks, only: lmh, dx, dy use params_mod, only: d00 use ctlblk_mod, only: lm, jsta_2l, jend_2u, jsta_m, jend_m, & - global, spval, im, jm + global, spval, im, jm, & + ista_2l, iend_2u, ista_m, iend_m use gridspec_mod, only: gridtype use upp_math, only: DVDXDUDY, DDVDX, DDUDY @@ -54,7 +36,7 @@ SUBROUTINE CALUPDHEL(UPDHEL) REAL, PARAMETER:: HLOWER=2000., HUPPER=5000. REAL ZMIDLOC real :: r2dx, r2dy, dz, dcdx, dudy, dvdx - REAL :: HTSFC(IM,jsta_2l:jend_2u),UPDHEL(IM,jsta_2l:jend_2u) + REAL :: HTSFC(ista_2l:iend_2u,jsta_2l:jend_2u),UPDHEL(ista_2l:iend_2u,jsta_2l:jend_2u) integer :: l, j, i INTEGER, dimension(jm) :: IHE,IHW ! INTEGER DXVAL,DYVAL,CENLAT,CENLON,TRUELAT1,TRUELAT2 @@ -67,16 +49,16 @@ SUBROUTINE CALUPDHEL(UPDHEL) ! maxval(WH(:,:,20)) DO L=1,LM - CALL EXCH(UH(1,jsta_2l,L)) + CALL EXCH(UH(ista_2l,jsta_2l,L)) END DO IF (GRIDTYPE == 'B')THEN DO L=1,LM - CALL EXCH(VH(1,jsta_2l,L)) + CALL EXCH(VH(ista_2l,jsta_2l,L)) END DO END IF !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U UPDHEL(I,J) = D00 ENDDO ENDDO @@ -93,13 +75,15 @@ SUBROUTINE CALUPDHEL(UPDHEL) !$omp parallel do private(i,j) DO J=JSTA_M,JEND_M - DO I=1,IM + DO I=ISTA_M,IEND_M HTSFC(I,J) = ZINT(I,J,NINT(LMH(I,J))+1) ENDDO ENDDO DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M + + IF (HTSFC(I,J) < spval) THEN R2DX = 1./(2.*DX(I,J)) R2DY = 1./(2.*DY(I,J)) @@ -137,6 +121,11 @@ SUBROUTINE CALUPDHEL(UPDHEL) ENDIF ENDDO l_loop + + ELSE + UPDHEL(I,J) = spval + ENDIF + ENDDO ENDDO ! diff --git a/sorc/ncep_post.fd/CALVESSEL.f b/sorc/ncep_post.fd/CALVESSEL.f index 9dae6d633..09d329ed1 100644 --- a/sorc/ncep_post.fd/CALVESSEL.f +++ b/sorc/ncep_post.fd/CALVESSEL.f @@ -1,20 +1,24 @@ SUBROUTINE CALVESSEL(ICEG) ! Algorithm for calculating ice growth rate +! +! PROGRAM HISTORY LOG: +! 21-10-31 JESSE MENG - 2D DECOMPOSITION + use vrbls2d, only: sst, u10h, v10h, tshltr use masks, only: sm, sice - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: jsta, jend, im, spval, ista, iend !------------------------------------------- implicit none integer I, J real TSFC_C,TSHLTR_C,SST_C real, parameter :: C2K=273.15 - real, dimension(im,jsta:jend) :: pr, spd10 - real,intent(out) :: ICEG(im,jsta:jend) + real, dimension(ista:iend,jsta:jend) :: pr, spd10 + real,intent(out) :: ICEG(ista:iend,jsta:jend) -! allocate (thsfc(im,jsta:jend),tsfc(im,jsta:jend)) +! allocate (thsfc(ista:iend,jsta:jend),tsfc(ista:iend,jsta:jend)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! CALCULATE SPEED SPD10(i,j)=SQRT(U10H(I,J)**2+V10H(I,J)**2) if (SPD10(i,j)>50) then diff --git a/sorc/ncep_post.fd/CALVIS.f b/sorc/ncep_post.fd/CALVIS.f index 6bcf0ee25..a7bf26fe2 100644 --- a/sorc/ncep_post.fd/CALVIS.f +++ b/sorc/ncep_post.fd/CALVIS.f @@ -57,15 +57,17 @@ SUBROUTINE CALVIS(QV,QC,QR,QI,QS,TT,PP,VIS) ! ! 2021-05 Wen Meng -Add checking for undfined points invloved in ! computation. +! 2021-10-31 Jesse Meng - 2D DECOMPOSITION !------------------------------------------------------------------ use params_mod, only: h1, d608, rd - use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, spval + use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, spval, & + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: QV,QC,QR,QI,QS,TT,PP - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: VIS + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: QV,QC,QR,QI,QS,TT,PP + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: VIS CHARACTER METH*1 real CELKEL,TICE,COEFLC,COEFLP,COEFFC,COEFFP,EXPONLC, & @@ -90,7 +92,7 @@ SUBROUTINE CALVIS(QV,QC,QR,QI,QS,TT,PP,VIS) RHOWAT=1000. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND VIS(I,J)=SPVAL ! IF(IICE==0)THEN ! QPRC=QR diff --git a/sorc/ncep_post.fd/CALVIS_GSD.f b/sorc/ncep_post.fd/CALVIS_GSD.f index ecd5d36b4..d5fabfe72 100644 --- a/sorc/ncep_post.fd/CALVIS_GSD.f +++ b/sorc/ncep_post.fd/CALVIS_GSD.f @@ -90,21 +90,24 @@ SUBROUTINE CALVIS_GSD(CZEN,VIS) ! 2021-05 Wen Meng Unify CONST1 and VISRH. ! 2021-05 Wen Meng - Add checking for undefined points invloved in computation ! 2021-08 Wen Meng - Restrict divided by 0. +! 2021-10 Jesse Meng - 2D DECOMPOSITION ! !------------------------------------------------------------------ ! use vrbls3d, only: qqw, qqi, qqs, qqr, qqg, t, pmid, q, u, v, extcof55, aextc55 use params_mod, only: h1, d608, rd - use ctlblk_mod, only: jm, im, jsta_2l, jend_2u, lm, modelname, spval + use ctlblk_mod, only: jm, im, jsta_2l, jend_2u, lm, modelname, spval,& + ista_2l, iend_2u implicit none integer :: j, i, k, ll integer :: method real :: tx, pol, esx, es, e - REAL VIS(IM,jsta_2l:jend_2u) ,RHB(IM,jsta_2l:jend_2u,LM), CZEN(IM,jsta_2l:jend_2u) - + REAL VIS(ista_2l:iend_2u,jsta_2l:jend_2u) + REAL RHB(ista_2l:iend_2u,jsta_2l:jend_2u,LM) + REAL CZEN(ista_2l:iend_2u,jsta_2l:jend_2u) real celkel,tice,coeflc,coeflp,coeffc,coeffp,coeffg real exponlc,exponlp,exponfc,exponfp,exponfg,const1 @@ -203,7 +206,7 @@ SUBROUTINE CALVIS_GSD(CZEN,VIS) visrh_min = 1.e6 DO J=jsta_2l,jend_2u - DO I=1,IM + DO I=ista_2l,iend_2u VIS(I,J)=spval ! -checking undedined points if(T(I,J,LM) @file -! -!> SUBPROGRAM: CALVOR COMPUTES ABSOLUTE VORTICITY -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE ABSOLUTE VORTICITY. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-01-15 MIKE BALDWIN - WRF VERSION C-GRID -!! 05-03-01 H CHUANG - ADD NMM E GRID -!! 05-05-17 H CHUANG - ADD POTENTIAL VORTICITY CALCULATION -!! 05-07-07 B ZHOU - ADD RSM IN COMPUTING DVDX, DUDY AND UAVG -!! 13-08-09 S MOORTHI - Optimize the vorticity loop including threading -!! 16-08-05 S Moorthi - add zonal filetering -!! 2019-10-17 Y Mao - Skip calculation when U/V is SPVAL -!! 2020-11-06 J Meng - USE UPP_MATH MODULE - - -!! -!! USAGE: CALL CALVOR(UWND,VWND,ABSV) -!! INPUT ARGUMENT LIST: -!! UWND - U WIND (M/S) MASS-POINTS -!! VWND - V WIND (M/S) MASS-POINTS -!! -!! OUTPUT ARGUMENT LIST: -!! ABSV - ABSOLUTE VORTICITY (1/S) MASS-POINTS -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : WCOSS -!! - SUBROUTINE CALVOR(UWND,VWND,ABSV) - -! -! - use vrbls2d, only: f - use masks, only: gdlat, gdlon, dx, dy - use params_mod, only: d00, dtr, small, erad - use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & - jsta, jend, im, jm, jsta_m, jend_m, gdsdegr - use gridspec_mod, only: gridtype, dyval - use upp_math, only: DVDXDUDY, DDVDX, DDUDY, UUAVG - - implicit none -! -! DECLARE VARIABLES. -! - REAL, dimension(im,jsta_2l:jend_2u), intent(in) :: UWND, VWND - REAL, dimension(im,jsta_2l:jend_2u), intent(inout) :: ABSV -! - real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:) - INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:) -! - integer, parameter :: npass2=2, npass3=3 - integer I,J,ip1,im1,ii,iir,iil,jj,JMT2,imb2, npass, nn, jtem - real R2DX,R2DY,DVDX,DUDY,UAVG,TPH1,TPHI, tx1(im+2), tx2(im+2) -! -!*************************************************************************** -! START CALVOR HERE. -! -! LOOP TO COMPUTE ABSOLUTE VORTICITY FROM WINDS. -! - IF(MODELNAME == 'RAPR') then -!$omp parallel do private(i,j) - DO J=JSTA_2L,JEND_2U - DO I=1,IM - ABSV(I,J) = D00 - ENDDO - ENDDO - else -!$omp parallel do private(i,j) - DO J=JSTA_2L,JEND_2U - DO I=1,IM - ABSV(I,J) = SPVAL - ENDDO - ENDDO - endif - -! print*,'dyval in CALVOR= ',DYVAL - - CALL EXCH_F(UWND) -! - IF (MODELNAME == 'GFS' .or. global) THEN - CALL EXCH(GDLAT(1,JSTA_2L)) - - allocate (wrk1(im,jsta:jend), wrk2(im,jsta:jend), & - & wrk3(im,jsta:jend), cosl(im,jsta_2l:jend_2u)) - allocate(iw(im),ie(im)) - - imb2 = im/2 -!$omp parallel do private(i) - do i=1,im - ie(i) = i+1 - iw(i) = i-1 - enddo - iw(1) = im - ie(im) = 1 - -! if(1>=jsta .and. 1<=jend)then -! if(cos(gdlat(1,1)*dtr)= SMALL) then - wrk1(i,j) = 1.0 / (ERAD*cosl(i,j)) - else - wrk1(i,j) = 0. - end if - if(i == im .or. i == 1) then - wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam - else - wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam - end if - enddo - enddo -! CALL EXCH(cosl(1,JSTA_2L)) - CALL EXCH(cosl) - -!$omp parallel do private(i,j,ii) - DO J=JSTA,JEND - if (j == 1) then - if(gdlat(1,j) > 0.) then ! count from north to south - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi - enddo - else ! count from south to north - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi -! - enddo - end if - elseif (j == JM) then - if(gdlat(1,j) < 0.) then ! count from north to south - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) - enddo - else ! count from south to north - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR) - enddo - end if - else - do i=1,im - wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi - enddo - endif - enddo - - npass = 0 - - jtem = jm / 18 + 1 -!$omp parallel do private(i,j,ip1,im1,ii,jj,tx1,tx2) - DO J=JSTA,JEND -! npass = npass2 -! if (j > jm-jtem+1 .or. j < jtem) npass = npass3 - IF(J == 1) then ! Near North or South pole - if(gdlat(1,j) > 0.) then ! count from north to south - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & - UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & - & + (UWND(II,J)*COSL(II,J) & - & + UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) & - & + F(I,J) - enddo - ELSE !pole point, compute at j=2 - jj = 2 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & - UWND(I,J)==SPVAL .or. UWND(I,jj+1)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & - & - (UWND(I,J)*COSL(I,J) & - - UWND(I,jj+1)*COSL(I,Jj+1))*wrk3(i,jj)) * wrk1(i,jj) & - & + F(I,Jj) - enddo - ENDIF - else - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & - UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & - & - (UWND(II,J)*COSL(II,J) & - & + UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) & - & + F(I,J) - enddo - ELSE !pole point, compute at j=2 - jj = 2 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & - UWND(I,J)==SPVAL .or. UWND(I,jj+1)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & - & + (UWND(I,J)*COSL(I,J) & - - UWND(I,jj+1)*COSL(I,Jj+1))*wrk3(i,jj)) * wrk1(i,jj) & - & + F(I,Jj) - enddo - ENDIF - endif - ELSE IF(J == JM) THEN ! Near North or South Pole - if(gdlat(1,j) < 0.) then ! count from north to south - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & - UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & - & - (UWND(I,J-1)*COSL(I,J-1) & - & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) & - & + F(I,J) - enddo - ELSE !pole point,compute at jm-1 - jj = jm-1 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & - UWND(I,jj-1)==SPVAL .or. UWND(I,J)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & - & - (UWND(I,jj-1)*COSL(I,Jj-1) & - & - UWND(I,J)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) & - & + F(I,Jj) - enddo - ENDIF - else - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & - UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & - & + (UWND(I,J-1)*COSL(I,J-1) & - & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) & - & + F(I,J) - enddo - ELSE !pole point,compute at jm-1 - jj = jm-1 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & - UWND(I,jj-1)==SPVAL .or. UWND(I,J)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & - & + (UWND(I,jj-1)*COSL(I,Jj-1) & - & - UWND(I,J)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) & - & + F(I,Jj) - enddo - ENDIF - endif - ELSE - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & - UWND(I,J-1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle - ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & - & - (UWND(I,J-1)*COSL(I,J-1) & - - UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) & - + F(I,J) - ENDDO - END IF -! if(ABSV(I,J)>1.0)print*,'Debug CALVOR',i,j,VWND(ip1,J),VWND(im1,J), & -! wrk2(i,j),UWND(I,J-1),COSL(I,J-1),UWND(I,J+1),COSL(I,J+1),wrk3(i,j),cosl(i,j),F(I,J),ABSV(I,J) - if (npass > 0) then - do i=1,im - tx1(i) = absv(i,j) - enddo - do nn=1,npass - do i=1,im - tx2(i+1) = tx1(i) - enddo - tx2(1) = tx2(im+1) - tx2(im+2) = tx2(2) - do i=2,im+1 - tx1(i-1) = 0.25 * (tx2(i-1) + tx2(i+1)) + 0.5*tx2(i) - enddo - enddo - do i=1,im - absv(i,j) = tx1(i) - enddo - endif - END DO ! end of J loop - -! deallocate (wrk1, wrk2, wrk3, cosl) -! GFS use lon avg as one scaler value for pole point - - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,ABSV(1,jsta)) - deallocate (wrk1, wrk2, wrk3, cosl, iw, ie) - - ELSE !(MODELNAME == 'GFS' .or. global) - - IF (GRIDTYPE == 'B')THEN - CALL EXCH_F(VWND) - ENDIF - - CALL DVDXDUDY(UWND,VWND) - - IF(GRIDTYPE == 'A')THEN -!$omp parallel do private(i,j,jmt2,tphi,r2dx,r2dy,dvdx,dudy,uavg) - DO J=JSTA_M,JEND_M - JMT2 = JM/2+1 - TPHI = (J-JMT2)*(DYVAL/gdsdegr)*DTR - DO I=2,IM-1 - IF(VWND(I+1,J)= SMALL) then - wrk1(i,j) = 1.0 / (ERAD*cosl(i,j)) - else - wrk1(i,j) = 0. - end if - if(i == im .or. i == 1) then - wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam - else - wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam - end if - enddo - ENDDO - - CALL EXCH(cosl) - -!$omp parallel do private(i,j,ii) - DO J=JSTA,JEND - if (j == 1) then - if(gdlat(1,j) > 0.) then ! count from north to south - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi - enddo - else ! count from south to north - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi - enddo - end if - elseif (j == JM) then - if(gdlat(1,j) < 0.) then ! count from north to south - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) - enddo - else ! count from south to north - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR) - enddo - end if - else - do i=1,im - wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi - enddo - endif - enddo - - do l=1,lm -!$omp parallel do private(i,j) - DO J=JSTA,JEND - DO I=1,IM - DIV(I,J,l) = SPVAL - ENDDO - ENDDO - - CALL EXCH_F(VWND(1,jsta_2l,l)) - -!$omp parallel do private(i,j,ip1,im1,ii,jj) - DO J=JSTA,JEND - IF(J == 1) then ! Near North pole - if(gdlat(1,j) > 0.) then ! count from north to south - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & - & - (VWND(II,J,l)*COSL(II,J) & - & + VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) - enddo -!-- - ELSE !North pole point, compute at j=2 - jj = 2 - do i=1,im - ip1 = ie(i) - im1 = iw(i) - DIV(I,J,l) = ((UWND(ip1,jj,l)-UWND(im1,jj,l))*wrk2(i,jj) & - & + (VWND(I,J,l)*COSL(I,J) & - - VWND(I,jj+1,l)*COSL(I,jj+1))*wrk3(i,jj)) * wrk1(i,jj) - enddo -!-- - ENDIF - else - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & - & + (VWND(II,J,l)*COSL(II,J) & - & + VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) - enddo -!-- - ELSE !North pole point, compute at j=2 - jj = 2 - do i=1,im - ip1 = ie(i) - im1 = iw(i) - DIV(I,J,l) = ((UWND(ip1,jj,l)-UWND(im1,jj,l))*wrk2(i,jj) & - & - (VWND(I,J,l)*COSL(I,J) & - - VWND(I,jj+1,l)*COSL(I,jj+1))*wrk3(i,jj)) * wrk1(i,jj) - enddo - ENDIF - endif - ELSE IF(J == JM) THEN ! Near South pole - if(gdlat(1,j) < 0.) then ! count from north to south - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & - & + (VWND(I,J-1,l)*COSL(I,J-1) & - & + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) - enddo -!-- - ELSE !South pole point,compute at jm-1 - jj = jm-1 - do i=1,im - ip1 = ie(i) - im1 = iw(i) - DIV(I,J,l) = ((UWND(ip1,JJ,l)-UWND(im1,JJ,l))*wrk2(i,jj) & - & + (VWND(I,jj-1,l)*COSL(I,Jj-1) & - & - VWND(I,J,l)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) - - enddo - ENDIF - else - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & - & - (VWND(I,J-1,l)*COSL(I,J-1) & - & + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) - enddo -!-- - ELSE !South pole point,compute at jm-1 - jj = jm-1 - do i=1,im - ip1 = ie(i) - im1 = iw(i) - DIV(I,J,l) = ((UWND(ip1,JJ,l)-UWND(im1,JJ,l))*wrk2(i,jj) & - & - (VWND(I,jj-1,l)*COSL(I,Jj-1) & - & - VWND(I,J,l)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) - - enddo - ENDIF - endif - ELSE - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & - & + (VWND(I,J-1,l)*COSL(I,J-1) & - - VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) -!sk06132016 - if(DIV(I,J,l)>1.0)print*,'Debug in CALDIV',i,j,UWND(ip1,J,l),UWND(im1,J,l), & - & wrk2(i,j),VWND(I,J-1,l),COSL(I,J-1),VWND(I,J+1,l),COSL(I,J+1), & - & wrk3(i,j),wrk1(i,j),DIV(I,J,l) -!-- - ENDDO - ENDIF - ENDDO ! end of J loop - -! GFS use lon avg as one scaler value for pole point - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,DIV(1,jsta,l)) -!sk06142016e - if(DIV(1,jsta,l)>1.0)print*,'Debug in CALDIV',jsta,DIV(1,jsta,l) -! print*,'Debug in CALDIV',' jsta= ',jsta,DIV(1,jsta,l) - - enddo ! end of l looop -!-- - deallocate (wrk1, wrk2, wrk3, cosl, iw, ie) - - - END SUBROUTINE CALDIV - - SUBROUTINE CALGRADPS(PS,PSX,PSY) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALGRADPS COMPUTES GRADIENTS OF A SCALAR FIELD PS OR LNPS -! PRGRMMR: SAJAL KAR ORG: W/NP2 DATE: 16-05-05 -! -! ABSTRACT: -! FOR GFS, THIS ROUTINE COMPUTES HRIZONTAL GRADIENTS OF PS OR LNPS -! USING 2ND-ORDER CENTERED SCHEME ON A LAT-LON GRID -! -! PROGRAM HISTORY LOG: -! 16-05-05 SAJAL KAR REDUCED FROM CALVORT TO ZONAL AND MERIDIONAL -! GRADIENTS OF GIVEN SURFACE PRESSURE PS, OR LNPS -! -! USAGE: CALL CALGRADPS(PS,PSX,PSY) -! INPUT ARGUMENT LIST: -! PS - SURFACE PRESSURE (PA) MASS-POINTS -! -! OUTPUT ARGUMENT LIST: -! PSX - ZONAL GRADIENT OF PS AT MASS-POINTS -! PSY - MERIDIONAL GRADIENT OF PS AT MASS-POINTS -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! NONE -! LIBRARY: -! COMMON - CTLBLK -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : WCOSS -!$$$ -! - use masks, only: gdlat, gdlon - use params_mod, only: dtr, d00, small, erad - use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & - jsta, jend, im, jm, jsta_m, jend_m - use gridspec_mod, only: gridtype - - implicit none -! -! DECLARE VARIABLES. -! - REAL, dimension(im,jsta_2l:jend_2u), intent(in) :: PS - REAL, dimension(im,jsta_2l:jend_2u), intent(inout) :: PSX,PSY -! - real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:) - INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:) -! - integer I,J,ip1,im1,ii,iir,iil,jj,imb2 -! -!*************************************************************************** -! START CALGRADPS HERE. -! -! LOOP TO COMPUTE ZONAL AND MERIDIONAL GRADIENTS OF PS OR LNPS -! -!sk06162016 DO J=JSTA_2L,JEND_2U -!$omp parallel do private(i,j) - DO J=JSTA,JEND - DO I=1,IM - PSX(I,J) = SPVAL - PSY(I,J) = SPVAL -!sk PSX(I,J) = D00 -!sk PSY(I,J) = D00 - ENDDO - ENDDO - - CALL EXCH_F(PS) - -! IF (MODELNAME == 'GFS' .or. global) THEN - CALL EXCH(GDLAT(1,JSTA_2L)) - - allocate (wrk1(im,jsta:jend), wrk2(im,jsta:jend), & - & wrk3(im,jsta:jend), cosl(im,jsta_2l:jend_2u)) - allocate(iw(im),ie(im)) - - imb2 = im/2 -!$omp parallel do private(i) - do i=1,im - ie(i) = i+1 - iw(i) = i-1 - enddo - iw(1) = im - ie(im) = 1 - - -!$omp parallel do private(i,j,ip1,im1) - DO J=JSTA,JEND - do i=1,im - ip1 = ie(i) - im1 = iw(i) - cosl(i,j) = cos(gdlat(i,j)*dtr) - if(cosl(i,j) >= SMALL) then - wrk1(i,j) = 1.0 / (ERAD*cosl(i,j)) - else - wrk1(i,j) = 0. - end if - if(i == im .or. i == 1) then - wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam - else - wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam - end if - enddo - ENDDO - - CALL EXCH(cosl) - -!$omp parallel do private(i,j,ii) - DO J=JSTA,JEND - if (j == 1) then - if(gdlat(1,j) > 0.) then ! count from north to south - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi - enddo - else ! count from south to north - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi - enddo - end if - elseif (j == JM) then - if(gdlat(1,j) < 0.) then ! count from north to south - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) - enddo - else ! count from south to north - do i=1,im - ii = i + imb2 - if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR) - enddo - end if - else - do i=1,im - wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi - enddo - endif - ENDDO - -!$omp parallel do private(i,j,ip1,im1,ii,jj) - DO J=JSTA,JEND - IF(J == 1) then ! Near North pole - if(gdlat(1,j) > 0.) then ! count from north to south - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) - PSY(I,J) = (PS(II,J)-PS(I,J+1))*wrk3(i,j)/ERAD - enddo - ELSE !North pole point, compute at j=2 - jj = 2 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - PSX(I,J) = (PS(ip1,jj)-PS(im1,jj))*wrk2(i,jj)*wrk1(i,jj) - PSY(I,J) = (PS(I,J)-PS(I,jj+1))*wrk3(i,jj)/ERAD - enddo - ENDIF - else - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) - PSY(I,J) = - (PS(II,J)-PS(I,J+1))*wrk3(i,j)/ERAD - enddo - ELSE !North pole point, compute at j=2 - jj = 2 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - PSX(I,J) = (PS(ip1,jj)-PS(im1,jj))*wrk2(i,jj)*wrk1(i,jj) - PSY(I,J) = - (PS(I,J)-PS(I,jj+1))*wrk3(i,jj)/ERAD - enddo - ENDIF - endif - ELSE IF(J == JM) THEN ! Near South pole - if(gdlat(1,j) < 0.) then ! count from north to south - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) - PSY(I,J) = (PS(I,J-1)-PS(II,J))*wrk3(i,j)/ERAD - enddo - ELSE !South pole point,compute at jm-1 - jj = jm-1 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - PSX(I,J) = (PS(ip1,JJ)-PS(im1,JJ))*wrk2(i,jj)*wrk1(i,jj) - PSY(I,J) = (PS(I,jj-1)-PS(I,J))*wrk3(i,jj)/ERAD - enddo - ENDIF - else - IF(cosl(1,j) >= SMALL) THEN !not a pole point - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - ii = i + imb2 - if (ii > im) ii = ii - im - PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) - PSY(I,J) = - (PS(I,J-1)-PS(II,J))*wrk3(i,j)/ERAD - enddo - ELSE !South pole point,compute at jm-1 - jj = jm-1 - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - PSX(I,J) = (PS(ip1,JJ)-PS(im1,JJ))*wrk2(i,jj)*wrk1(i,jj) - PSY(I,J) = - (PS(I,jj-1)-PS(I,J))*wrk3(i,jj)/ERAD - enddo - ENDIF - endif - ELSE - DO I=1,IM - ip1 = ie(i) - im1 = iw(i) - PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) - PSY(I,J) = (PS(I,J-1)-PS(I,J+1))*wrk3(i,j)/ERAD -!sk06142016A - if(PSX(I,J)>100.0)print*,'Debug in CALGRADPS: PSX',i,j,PS(ip1,J),PS(im1,J), & -! print*,'Debug in CALGRADPS',i,j,PS(ip1,J),PS(im1,J), & - & wrk2(i,j),wrk1(i,j),PSX(I,J) - if(PSY(I,J)>100.0)print*,'Debug in CALGRADPS: PSY',i,j,PS(i,J-1),PS(i,J+1), & -! print*,'Debug in CALGRADPS',i,j,PS(i,J-1),PS(i,J+1), & - & wrk3(i,j),ERAD,PSY(I,J) -!-- - ENDDO - END IF -! - ENDDO ! end of J loop - - deallocate (wrk1, wrk2, wrk3, cosl, iw, ie) - -! END IF - - END SUBROUTINE CALGRADPS diff --git a/sorc/ncep_post.fd/CALWXT.f b/sorc/ncep_post.fd/CALWXT.f index a50a6065c..48aac1332 100644 --- a/sorc/ncep_post.fd/CALWXT.f +++ b/sorc/ncep_post.fd/CALWXT.f @@ -10,6 +10,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! 05-07-07 BINBIN ZHOU - ADD PREC FOR RSM ! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT ! 21-07-26 Wen Meng - Restrict computation from undefined grids +! 21-10-31 JESSE MENG - 2D DECOMPOSITION ! ! ! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE @@ -22,19 +23,20 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! use params_mod, only: h1m12, d00, d608, h1, rog use ctlblk_mod, only: jsta, jend, spval, modelname,pthresh, im, & - jsta_2l, jend_2u, lm, lp1 + jsta_2l, jend_2u, lm, lp1, & + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! INPUT: ! T,Q,PMID,HTM,LMH,PREC,ZINT ! - real,dimension(IM,jsta_2l:jend_2u),intent(in) :: LMH - real,dimension(IM,jsta_2l:jend_2u,LM),intent(in) :: T,Q,PMID,HTM - real,dimension(IM,jsta_2l:jend_2u,LP1),intent(in) :: ZINT,PINT - integer,DIMENSION(IM,jsta:jend),intent(inout) :: IWX - real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: PREC - real,DIMENSION(IM,jsta:jend),intent(inout) :: ZWET + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(in) :: LMH + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(in) :: T,Q,PMID,HTM + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LP1),intent(in) :: ZINT,PINT + integer,DIMENSION(ista:iend,jsta:jend),intent(inout) :: IWX + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(inout) :: PREC + real,DIMENSION(ista:iend,jsta:jend),intent(inout) :: ZWET ! OUTPUT: @@ -49,8 +51,8 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! INTERNAL: ! REAL, ALLOCATABLE :: TWET(:,:,:) - integer,DIMENSION(IM,jsta:jend) :: KARR,LICEE - real, DIMENSION(IM,jsta:jend) :: TCOLD,TWARM + integer,DIMENSION(ista:iend,jsta:jend) :: KARR,LICEE + real, DIMENSION(ista:iend,jsta:jend) :: TCOLD,TWARM logical :: jcontinue=.true. ! SUBROUTINES CALLED: @@ -69,12 +71,12 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4, & SURFW,SURFC,DZKL,AREA1,PINTK1,PINTK2,PM150,PKL,TKL,QKL - ALLOCATE ( TWET(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! !!$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX(I,J) = 0 ZWET(I,J) = SPVAL ! if (I == 324 .and. J == 390) then @@ -88,7 +90,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) IF(MODELNAME=='RSM') THEN !add by Binbin because of different unit DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PREC(I,J) = PREC(I,J)*3*3600.0 ENDDO ENDDO @@ -98,7 +100,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! !!$omp parallel do private(a,lmhk,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) DO 800 J=JSTA,JEND - DO 800 I=1,IM + DO 800 I=ISTA,IEND LMHK=NINT(LMH(I,J)) ! ! SKIP THIS POINT IF NO PRECIP THIS TIME STEP @@ -155,7 +157,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! LOWEST LAYER T ! DO 850 J=JSTA,JEND - DO 850 I=1,IM + DO 850 I=ISTA,IEND KARR(I,J)=0 IF (PREC(I,J)<=PTHRESH) cycle LMHK=NINT(LMH(I,J)) @@ -195,7 +197,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) ! & lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, & ! & tlmhk,twrmk) DO 1900 J=JSTA,JEND - DO 1900 I=1,IM + DO 1900 I=ISTA,IEND ! IF (I == 324 .AND. J == 390) THEN ! LMHK=NINT(LMH(I,J)) ! DO L=LMHK,1,-1 @@ -318,7 +320,7 @@ SUBROUTINE CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX,ZWET) IF(MODELNAME == 'RSM') THEN !add by Binbin, change back !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PREC(I,J) = PREC(I,J)/(3*3600.0) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/CALWXT_BOURG.f b/sorc/ncep_post.fd/CALWXT_BOURG.f index aef3300f1..51fb0a3d0 100644 --- a/sorc/ncep_post.fd/CALWXT_BOURG.f +++ b/sorc/ncep_post.fd/CALWXT_BOURG.f @@ -1,84 +1,72 @@ !> @file -! -!> Subprogram: calwxt_bourg Calculate precipitation type (Bourgouin) -!! Prgmmr: Baldwin Org: np22 Date: 1999-07-06 -!! -!! Abstract: This routine computes precipitation type -!! using a decision tree approach that uses the so-called -!! "energy method" of Bourgouin of AES (Canada) 1992 -!! -!! Program history log: -!! 1999-07-06 M Baldwin -!! 1999-09-20 M Baldwin make more consistent with bourgouin (1992) -!! 2005-08-24 G Manikin added to wrf post -!! 2007-06-19 M Iredell mersenne twister, best practices -!! 2015-00-00 S Moorthi changed random number call and optimization and cleanup -!! -!! Usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & -!! & iseed,g,pthresh, & -!! & t,q,pmid,pint,lmh,prec,zint,ptype) -!! Input argument list: -!! im integer i dimension -!! jm integer j dimension -!! jsta_2l integer j dimension start point (including haloes) -!! jend_2u integer j dimension end point (including haloes) -!! jsta integer j dimension start point (excluding haloes) -!! jend integer j dimension end point (excluding haloes) -!! lm integer k dimension -!! lp1 integer k dimension plus 1 -!! iseed integer random number seed -!! g real gravity (m/s**2) -!! pthresh real precipitation threshold (m) -!! t real(im,jsta_2l:jend_2u,lm) mid layer temp (K) -!! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) -!! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa) -!! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (Pa) -!! lmh real(im,jsta_2l:jend_2u) max number of layers -!! prec real(im,jsta_2l:jend_2u) precipitation (m) -!! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) -!! Output argument list: -!! ptype integer(im,jm) instantaneous weather type () -!! acts like a 4 bit binary -!! 1111 = rain/freezing rain/ice pellets/snow -!! where the one's digit is for snow -!! the two's digit is for ice pellets -!! the four's digit is for freezing rain -!! and the eight's digit is for rain -!! in other words... -!! ptype=1 snow -!! ptype=2 ice pellets/mix with ice pellets -!! ptype=4 freezing rain/mix with freezing rain -!! ptype=8 rain -!! -!! Modules used: -!! mersenne_twister pseudo-random number generator -!! -!! Subprograms called: -!! random_number pseudo-random number generator -!! -!! Attributes: -!! Language: Fortran 90 -!! -!! Remarks: vertical order of arrays must be layer 1 = top -!! and layer lmh = bottom -!! -!! +!> @brief Subroutine that calculate precipitation type (Bourgouin). +!> +!> This routine computes precipitation type. +!> using a decision tree approach that uses the so-called +!> "energy method" of Bourgouin of AES (Canada) 1992. +!> +!> @param[in] im integer i dimension. +!> @param[in] jm integer j dimension. +!> @param[in] jsta_2l integer j dimension start point (including haloes). +!> @param[in] jend_2u integer j dimension end point (including haloes). +!> @param[in] jsta integer j dimension start point (excluding haloes). +!> @param[in] jend integer j dimension end point (excluding haloes). +!> @param[in] lm integer k dimension. +!> @param[in] lp1 integer k dimension plus 1. +!> @param[in] iseed integer random number seed. +!> @param[in] g real gravity (m/s**2). +!> @param[in] pthresh real precipitation threshold (m). +!> @param[in] t real(im,jsta_2l:jend_2u,lm) mid layer temp (K). +!> @param[in] q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg). +!> @param[in] pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa). +!> @param[in] pint real(im,jsta_2l:jend_2u,lp1) interface pressure (Pa). +!> @param[in] lmh real(im,jsta_2l:jend_2u) max number of layers. +!> @param[in] prec real(im,jsta_2l:jend_2u) precipitation (m). +!> @param[in] zint real(im,jsta_2l:jend_2u,lp1) interface height (m). +!> @param[out] ptype integer(im,jm) instantaneous weather type () acts like a 4 bit binary 1111 = rain/freezing rain/ice pellets/snow. +!>
+!>                   where the one's digit is for snow
+!>                         the two's digit is for ice pellets
+!>                         the four's digit is for freezing rain
+!>                         and the eight's digit is for rain
+!>                         in other words...
+!>                         ptype=1 snow
+!>                         ptype=2 ice pellets/mix with ice pellets
+!>                         ptype=4 freezing rain/mix with freezing rain
+!>                         ptype=8 rain
+!>
+!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-07-06 | M Baldwin | Initial +!> 1999-09-20 | M Baldwin | make more consistent with bourgouin (1992) +!> 2005-08-24 | G Manikin | added to wrf post +!> 2007-06-19 | M Iredell | mersenne twister, best practices +!> 2015-??-?? | S Moorthi | changed random number call and optimization and cleanup +!> 2021-10-31 | J Meng | 2D DECOMPOSITION +!> +!> Remarks: vertical order of arrays must be layer 1 = top +!> and layer lmh = bottom +!> +!> @author M Baldwin np22 @date 1999-07-06 - subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & + subroutine calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & & iseed,g,pthresh, & & t,q,pmid,pint,lmh,prec,zint,ptype,me) implicit none ! ! input: - integer,intent(in):: im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,iseed,me + integer,intent(in):: im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,iseed,me,& + ista_2l,iend_2u,ista,iend real,intent(in):: g,pthresh - real,intent(in), dimension(im,jsta_2l:jend_2u,lm) :: t, q, pmid - real,intent(in), dimension(im,jsta_2l:jend_2u,lp1) :: pint, zint - real,intent(in), dimension(im,jsta_2l:jend_2u) :: lmh, prec + real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm) :: t, q, pmid + real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lp1) :: pint, zint + real,intent(in), dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: lmh, prec ! ! output: ! real,intent(out) :: ptype(im,jm) - integer,intent(out) :: ptype(im,jsta:jend) + integer,intent(out) :: ptype(ista:iend,jsta:jend) ! integer i,j,ifrzl,iwrml,l,lhiwrm,lmhk,jlen real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 @@ -97,7 +85,7 @@ subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & ! !$omp parallel do do j=jsta,jend - do i=1,im + do i=ista,iend ptype(i,j) = 0 enddo enddo @@ -117,7 +105,7 @@ subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & do j=jsta,jend ! if(me==1)print *,'incalwxtbg, j=',j - do i=1,im + do i=ista,iend lmhk = min(nint(lmh(i,j)),lm) psfck = pint(i,j,lmhk+1) ! diff --git a/sorc/ncep_post.fd/CALWXT_DOMINANT.f b/sorc/ncep_post.fd/CALWXT_DOMINANT.f index 6d397be45..7912d80fd 100644 --- a/sorc/ncep_post.fd/CALWXT_DOMINANT.f +++ b/sorc/ncep_post.fd/CALWXT_DOMINANT.f @@ -1,28 +1,32 @@ SUBROUTINE CALWXT_DOMINANT_POST(PREC,RAIN,FREEZR,SLEET,SNOW, & & DOMR,DOMZR,DOMIP,DOMS) ! -! WRITTEN: 24 AUGUST 2005, G MANIKIN +! WRITTEN: 24 AUGUST 2005, G MANIKIN +! +! PROGRAM HISTORY LOG: +! 21-10-31 JESSE MENG - 2D DECOMPOSITION ! ! THIS ROUTINE TAKES THE PRECIP TYPE SOLUTIONS FROM DIFFERENT ! ALGORITHMS AND SUMS THEM UP TO GIVE A DOMINANT TYPE ! ! use params_mod - use ctlblk_mod, only: jsta, jend, pthresh, im, jsta_2l, jend_2u + use ctlblk_mod, only: jsta, jend, pthresh, im, jsta_2l, jend_2u, & + ista, iend, ista_2l, iend_2u ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! integer,PARAMETER :: NALG=5 ! INPUT: - REAL PREC(IM,jsta_2l:jend_2u) - real,DIMENSION(IM,jsta:jend), intent(inout) :: DOMS,DOMR,DOMZR,DOMIP - real,DIMENSION(IM,jsta:jend,NALG),intent(in) :: RAIN,SNOW,SLEET,FREEZR + REAL PREC(ista_2l:iend_2u,jsta_2l:jend_2u) + real,DIMENSION(ista:iend,jsta:jend), intent(inout) :: DOMS,DOMR,DOMZR,DOMIP + real,DIMENSION(ista:iend,jsta:jend,NALG),intent(in) :: RAIN,SNOW,SLEET,FREEZR integer I,J,L real TOTSN,TOTIP,TOTR,TOTZR !-------------------------------------------------------------------------- !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DOMR(I,J) = 0. DOMS(I,J) = 0. DOMZR(I,J) = 0. @@ -32,7 +36,7 @@ SUBROUTINE CALWXT_DOMINANT_POST(PREC,RAIN,FREEZR,SLEET,SNOW, & ! !$omp parallel do private(i,j,totsn,totip,totr,totzr) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! SKIP THIS POINT IF NO PRECIP THIS TIME STEP IF (PREC(I,J) <= PTHRESH) cycle TOTSN = 0 diff --git a/sorc/ncep_post.fd/CALWXT_EXPLICIT.f b/sorc/ncep_post.fd/CALWXT_EXPLICIT.f index 36fb23d17..1b8b78367 100644 --- a/sorc/ncep_post.fd/CALWXT_EXPLICIT.f +++ b/sorc/ncep_post.fd/CALWXT_EXPLICIT.f @@ -5,10 +5,13 @@ SUBROUTINE CALWXT_EXPLICIT_POST(LMH,THS,PMID,PREC,SR,F_RIMEF,IWX) ! ! ROUTINE TO COMPUTE PRECIPITATION TYPE USING EXPLICIT FIELDS ! FROM THE MODEL MICROPHYSICS +! +! PROGRAM HISTORY LOG: +! 21-10-31 JESSE MENG - 2D DECOMPOSITION use params_mod, only: p1000, capa use ctlblk_mod, only: jsta, jend, modelname, pthresh, im, jsta_2l, & - jend_2u, lm + jend_2u, lm, ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -16,9 +19,9 @@ SUBROUTINE CALWXT_EXPLICIT_POST(LMH,THS,PMID,PREC,SR,F_RIMEF,IWX) ! PARAMETERS: ! ! INPUT: - real,dimension(im,jsta_2l:jend_2u,lm),intent(in) :: F_RimeF, pmid - REAL,dimension(im,jsta_2l:jend_2u), intent(in) :: LMH, PREC, THS, SR - integer,dimension(im,jsta:jend), intent(inout) :: IWX + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm),intent(in) :: F_RimeF, pmid + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: LMH, PREC, THS, SR + integer,dimension(ista:iend,jsta:jend), intent(inout) :: IWX integer I,J,LMHK real PSFC,TSKIN,SNOW ! @@ -26,7 +29,7 @@ SUBROUTINE CALWXT_EXPLICIT_POST(LMH,THS,PMID,PREC,SR,F_RIMEF,IWX) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX(I,J) = 0 ENDDO ENDDO @@ -34,7 +37,7 @@ SUBROUTINE CALWXT_EXPLICIT_POST(LMH,THS,PMID,PREC,SR,F_RIMEF,IWX) ! !$omp parallel do private(j,i,lmhk,psfc,tskin) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LMHK=LMH(I,J) ! ! SKIP THIS POINT IF NO PRECIP THIS TIME STEP diff --git a/sorc/ncep_post.fd/CALWXT_RAMER.f b/sorc/ncep_post.fd/CALWXT_RAMER.f index b05f64922..5c573db20 100644 --- a/sorc/ncep_post.fd/CALWXT_RAMER.f +++ b/sorc/ncep_post.fd/CALWXT_RAMER.f @@ -7,9 +7,10 @@ ! Weather Systems, Vienna, VA, Amer. Meteor. Soc., 227-230. ! ! CODE ADAPTED FOR WRF POST 24 AUGUST 2005 G MANIKIN - +! ! PROGRAM HISTORY LOG: ! 10-30-19 Bo CUI - Remove "GOTO" statement +! 21-10-31 JESSE MENG - 2D DECOMPOSITION !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! SUBROUTINE CALWXT_RAMER_POST(T,Q,PMID,PINT,LMH,PREC,PTYP) @@ -24,7 +25,8 @@ SUBROUTINE CALWXT_RAMER_POST(T,Q,PMID,PINT,LMH,PREC,PTYP) ! + ptyp) ! output(2) phase 2=Rain, 3=Frzg, 4=Solid, ! 6=IP JC 9/16/99 use params_mod, only: pq0, a2, a3, a4 - use CTLBLK_mod, only: me, im, jsta_2l, jend_2u, lm, lp1, jsta, jend, pthresh + use CTLBLK_mod, only: me, im, jsta_2l, jend_2u, lm, lp1, jsta, jend, pthresh,& + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -37,13 +39,13 @@ SUBROUTINE CALWXT_RAMER_POST(T,Q,PMID,PINT,LMH,PREC,PTYP) INTEGER*4 i, k1, lll, k2, toodry, iflag, nq ! REAL xxx ,mye, icefrac,flg,flag - real,DIMENSION(IM,jsta_2l:jend_2u,LM), intent(in) :: T,Q,PMID - real,DIMENSION(IM,jsta_2l:jend_2u,LP1),intent(in) :: PINT - real,DIMENSION(IM,jsta_2l:jend_2u), intent(in) :: LMH,PREC - integer,DIMENSION(IM,jsta:jend), intent(inout) :: PTYP + real,DIMENSION(ista_2l:iend_2u,jsta_2l:jend_2u,LM), intent(in) :: T,Q,PMID + real,DIMENSION(ista_2l:iend_2u,jsta_2l:jend_2u,LP1),intent(in) :: PINT + real,DIMENSION(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: LMH,PREC + integer,DIMENSION(ista:iend,jsta:jend), intent(inout) :: PTYP ! - real,DIMENSION(IM,jsta_2l:jend_2u,LM) :: P,TQ,PQ,RHQ - real,DIMENSION(IM,jsta:jend,LM) :: TWQ + real,DIMENSION(ista_2l:iend_2u,jsta_2l:jend_2u,LM) :: P,TQ,PQ,RHQ + real,DIMENSION(ista:iend,jsta:jend,LM) :: TWQ ! REAL, ALLOCATABLE :: TWET(:,:,:) ! integer J,L,LEV,LNQ,LMHK,ii @@ -61,7 +63,7 @@ SUBROUTINE CALWXT_RAMER_POST(T,Q,PMID,PINT,LMH,PREC,PTYP) icefrac = flag ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PTYP(I,J) = 0 NQ=LMH(I,J) DO L = 1,NQ @@ -77,7 +79,7 @@ SUBROUTINE CALWXT_RAMER_POST(T,Q,PMID,PINT,LMH,PREC,PTYP) ! BIG LOOP DO 800 J=JSTA,JEND - DO 800 I=1,IM + DO 800 I=ISTA,IEND ! ! SKIP THIS POINT IF NO PRECIP THIS TIME STEP ! @@ -372,9 +374,7 @@ SUBROUTINE CALWXT_RAMER_POST(T,Q,PMID,PINT,LMH,PREC,PTYP) IF (trace) WRITE (*,*) "Returned ptyp is:ptyp,lll ", ptyp, lll,'me=',me IF (trace) WRITE (*,*) "Returned icefrac is: ", icefrac,'me=',me 800 CONTINUE - DO 900 J=JSTA,JEND - DO 900 I=1,IM - 900 CONTINUE + RETURN ! END diff --git a/sorc/ncep_post.fd/CALWXT_REVISED.f b/sorc/ncep_post.fd/CALWXT_REVISED.f index c19134def..792680d09 100644 --- a/sorc/ncep_post.fd/CALWXT_REVISED.f +++ b/sorc/ncep_post.fd/CALWXT_REVISED.f @@ -11,6 +11,7 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) ! 05-08-24 GEOFF MANIKIN - MODIFIED THE AREA REQUIREMENTS ! TO MAKE AN ALTERNATE ALGORITHM ! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT +! 21-10-31 JESSE MENG - 2D DECOMPOSITION ! ! ! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE @@ -27,7 +28,7 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) ! use params_mod, only: h1m12, d00, d608, h1, rog use ctlblk_mod, only: jsta, jend, modelname, pthresh, im, jsta_2l, jend_2u, lm,& - lp1, spval + lp1, spval, ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -38,10 +39,10 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) ! ! INPUT: ! T,Q,PMID,HTM,LMH,PREC,ZINT - REAL,dimension(IM,jsta_2l:jend_2u,LM), intent(in) :: T,Q,PMID,HTM - REAL,dimension(IM,jsta_2l:jend_2u,LP1),intent(in) :: PINT,ZINT - REAL,dimension(IM,jsta_2l:jend_2u), intent(in) :: LMH - REAL,dimension(IM,jsta_2l:jend_2u), intent(in) :: PREC + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM), intent(in) :: T,Q,PMID,HTM + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LP1),intent(in) :: PINT,ZINT + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: LMH + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: PREC ! OUTPUT: ! IWX - INSTANTANEOUS WEATHER TYPE. ! ACTS LIKE A 4 BIT BINARY @@ -50,12 +51,12 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) ! THE TWO'S DIGIT IS FOR ICE PELLETS ! THE FOUR'S DIGIT IS FOR FREEZING RAIN ! AND THE EIGHT'S DIGIT IS FOR RAIN - integer, DIMENSION(IM,jsta:jend),intent(inout) :: IWX + integer, DIMENSION(ista:iend,jsta:jend),intent(inout) :: IWX ! INTERNAL: ! REAL, ALLOCATABLE :: TWET(:,:,:) - integer,DIMENSION(IM,jsta:jend) :: KARR,LICEE - real, dimension(IM,jsta:jend) :: TCOLD,TWARM + integer,DIMENSION(ista:iend,jsta:jend) :: KARR,LICEE + real, dimension(ista:iend,jsta:jend) :: TCOLD,TWARM ! integer I,J,L,LMHK,LICE,IFREL,IWRML,IFRZL real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4,AREA1, & @@ -75,11 +76,11 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) ! ! ALLOCATE LOCAL STORAGE ! - ALLOCATE ( TWET(IM,JSTA_2L:JEND_2U,LM) ) + ALLOCATE ( TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) ) ! !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX(I,J) = 0 ENDDO ENDDO @@ -88,7 +89,7 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) !!$omp parallel do !!$omp& private(a,lmhk,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) DO 800 J=JSTA,JEND - DO 800 I=1,IM + DO 800 I=ISTA,IEND LMHK=NINT(LMH(I,J)) ! ! SKIP THIS POINT IF NO PRECIP THIS TIME STEP @@ -145,7 +146,7 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) ! LOWEST LAYER T ! DO 850 J=JSTA,JEND - DO 850 I=1,IM + DO 850 I=ISTA,IEND KARR(I,J)=0 IF (PREC(I,J)<=PTHRESH) cycle LMHK=NINT(LMH(I,J)) @@ -184,7 +185,7 @@ SUBROUTINE CALWXT_REVISED_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX) !!$omp& lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, !!$omp& tlmhk,twrmk) DO 1900 J=JSTA,JEND - DO 1900 I=1,IM + DO 1900 I=ISTA,IEND IF(KARR(I,J)>0)THEN LMHK=NINT(LMH(I,J)) LICE=LICEE(I,J) diff --git a/sorc/ncep_post.fd/CLDRAD.f b/sorc/ncep_post.fd/CLDRAD.f index df5799171..d3d2160d4 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -1,99 +1,70 @@ !> @file -! . . . -!> SUBPROGRAM: CLDRAD POST SNDING/CLOUD/RADTN FIELDS -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-08-30 -!! -!! ABSTRACT: THIS ROUTINE COMPUTES/POSTS SOUNDING, CLOUD -!! RELATED, AND RADIATION FIELDS. UNDER THE HEADING OF -!! SOUNDING FIELDS FALL THE THREE ETA MODEL LIFTED INDICES, -!! CAPE, CIN, AND TOTAL COLUMN PRECIPITABLE WATER. -!! -!! THE THREE ETA MODEL LIFTED INDICES DIFFER ONLY IN THE -!! DEFINITION OF THE PARCEL TO LIFT. ONE LIFTS PARCELS FROM -!! THE LOWEST ABOVE GROUND ETA LAYER. ANOTHER LIFTS MEAN -!! PARCELS FROM ANY OF NBND BOUNDARY LAYERS (SEE SUBROUTINE -!! BNDLYR). THE FINAL TYPE OF LIFTED INDEX IS A BEST LIFTED -!! INDEX BASED ON THE NBND BOUNDARY LAYER LIFTED INDICES. -!! -!! TWO TYPES OF CAPE/CIN ARE AVAILABLE. ONE IS BASED ON PARCELS -!! IN THE LOWEST ETA LAYER ABOVE GROUND. THE OTHER IS BASED -!! ON A LAYER MEAN PARCEL IN THE N-TH BOUNDARY LAYER ABOVE -!! THE GROUND. SEE SUBROUTINE CALCAPE FOR DETAILS. -!! -!! THE CLOUD FRACTION AND LIQUID CLOUD WATER FIELDS ARE DIRECTLY -!! FROM THE MODEL WITH MINIMAL POST PROCESSING. THE LIQUID -!! CLOUD WATER, 3-D CLOUD FRACTION, AND TEMPERATURE TENDENCIES -!! DUE TO PRECIPITATION ARE NOT POSTED IN THIS ROUTINE. SEE -!! SUBROUTINE ETAFLD FOR THESE FIELDS. LIFTING CONDENSATION -!! LEVEL HEIGHT AND PRESSURE ARE COMPUTED AND POSTED IN -!! SUBROUTINE MISCLN. -!! -!! THE RADIATION FIELDS POSTED BY THIS ROUTINE ARE THOSE COMPUTED -!! DIRECTLY IN THE MODEL. -!! -!! PROGRAM HISTORY LOG: -!! 93-08-30 RUSS TREADON -!! 94-08-04 MICHAEL BALDWIN - ADDED OUTPUT OF INSTANTANEOUS SFC -!! FLUXES OF NET SW AND LW DOWN RADIATION -!! 97-04-25 MICHAEL BALDWIN - FIX PDS FOR PRECIPITABLE WATER -!! 97-04-29 GEOFF MANIKIN - MOVED CLOUD TOP TEMPS CALCULATION -!! TO THIS SUBROUTINE. CHANGED METHOD -!! OF DETERMINING WHERE CLOUD BASE AND -!! TOP ARE FOUND AND ADDED HEIGHT OPTION -!! FOR TOP AND BASE. -!! 98-04-29 GEOFF MANIKIN - CHANGED VALUE FOR CLOUD BASE/TOP PRESSURES -!! AND HEIGHTS FROM SPVAL TO -500 -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-07-17 MIKE BALDWIN - REMOVED LABL84 -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 00-02-22 GEOFF MANIKIN - CHANGED VALUE FOR CLOUD BASE/TOP PRESSURES -!! AND HEIGHTS FROM SPVAL TO -500 (WAS NOT IN -!! PREVIOUS IBM VERSION) -!! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 05-01-06 H CHUANG - ADD VARIOUS CLOUD FIELDS -!! 05-07-07 BINBIN ZHOU - ADD RSM MODEL -!! 05-08-30 BINBIN ZHOU - ADD CEILING and FLIGHT CONDITION RESTRICTION -!! 10-09-09 GEOFF MANIKIN - REVISED CALL TO CALCAPE -!! 11-02-06 Jun Wang - ADD GRIB2 OPTION -!! 11-12-14 SARAH LU - ADD AEROSOL OPTICAL PROPERTIES -!! 11-12-16 SARAH LU - ADD AEROSOL 2D DIAG FIELDS -!! 11-12-23 SARAH LU - CONSOLIDATE ALL GOCART FIELDS TO BLOCK 4 -!! 11-12-23 SARAH LU - ADD AOD AT ADDITIONAL CHANNELS -!! 12-04-03 Jun Wang - Add lftx and GFS convective cloud cover for grib2 -!! 13-05-06 Shrinivas Moorthi - Add cloud condensate to total precip water -!! 13-12-23 LU/Wang - READ AEROSOL OPTICAL PROPERTIES LUTS to compute dust aod, -!! non-dust aod, and use geos5 gocart LUTS -!! 15-??-?? S. Moorthi - threading, optimization, local dimension -!! 19-07-24 Li(Kate) Zhang Merge and update ARAH Lu's work from NGAC into FV3-Chem -!! 19-10-30 Bo CUI - Remove "GOTO" statement -!! 20-03-25 Jesse Meng - remove grib1 -!! 20-05-20 Jesse Meng - CALRH unification with NAM scheme -!! 20-11-10 Jesse Meng - USE UPP_PHYSICS MODULE -!! 21-02-08 Anning Cheng, read aod550, aod550_du/su/ss/oc/bc -!! directly from fv3gfs and output to grib2 by setting rdaod -!! 21-04-01 Jesse Meng - COMPUTATION ON DEFINED POINTS ONLY -!! -!! USAGE: CALL CLDRAD -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - RQSTFLD -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM SP -!! +!> @brief Subroutine that post SNDING/CLOUD/RADTN fields. +!> +!> This routine computes/posts sounding cloud +!> related, and radiation fields. Under the heading of +!> sounding fields fall the three ETA model lifted indices, +!> CAPE, CIN, and total column precipitable water. +!> +!> The three ETA model lifted indices differ only in the +!> definition of the parcel to lift. One lifts parcels from +!> the lowest above ground ETA layer. Another lifts mean +!> parcels from any of NBND boundary layers (See subroutine +!> BNDLYR). The final type of lifted index is a best lifted +!> inden based on the NBND bouddary layer lifted indices. +!> +!> Two types of CAPE/CIN are available. One is based on parcels +!> in the lowest ETA layer above ground. The other is based +!> on a layer mean parcel in the N-th boundary layer above +!> the ground. See subroutine CALCAPE for details. +!> +!> The cloud fraction and liquid cloud water fields are directly +!> from the model with minimal post processing. The liquid +!> cloud water, 3-D cloud fraction, and temperature tendencies +!> due to precipotation are not posted in this routine. See +!> sunroutine ETAFLD for these fields. Lifting condensation +!> level height and pressure are computed and posted in +!> subroutine MISCLN. +!> +!> The radiation fields posted by this routine are those computed +!> directly in the model. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-08-30 | Russ Treadon | Initial +!> 1994-08-04 | Mike Baldwin | Added output of instantaneous SFC fluxes of net SW and LW down radiation +!> 1997-04-25 | Mike Baldwin | Fix PDS for precipitable water +!> 1997-04-29 | Geoff Manikin | Moved cloud top temps calculation to this subroutine. Changed method of determining where cloud base and top are found and added height option for top and base +!> 1998-04-29 | Geoff Manikin | Changed value for cloud base/top pressures and heights from SPVAL to -500 +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 1998-07-17 | Mike Baldwin | Removed LABL84 +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2000-02-22 | Geoff Manikin | Changed value for cloud base/top pressures and heights from SPVAL to -500 (was not in previous IBM version) +!> 2001-10-22 | H Chuang | Modified to process hybrid model output +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2005-01-06 | H Chuang | Add various cloud fields +!> 2005-07-07 | Binbin Zhou | Add RSM model +!> 2005-08-30 | Binbin Zhou | Add ceiling and flight condition restriction +!> 2010-09-09 | Geoff Manikin | Revised call to CALCAPE +!> 2011-02-06 | Jun Wang | Add GRIB2 Option +!> 2011-12-14 | Sarah Lu | Add Aerosol optical properties +!> 2011-12-16 | Sarah Lu | Add Aerosol 2D DIAG fields +!> 2011-12-23 | Sarah Lu | Consolidate all GOCART fields to BLOCK 4 +!> 2011-12-23 | Sarah Lu | Add AOD at additional channels +!> 2012-04-03 | Jun Wang | Add lftx and GFS convective cloud cover for grib2 +!> 2013-05-06 | Shrinivas Moorthi | Add cloud condensate to total precip water +!> 2013-12-23 | Lu/Wang | Read aerosol optical properties LUTS to compute dust aod, non-dust aod, and use geos5 gocart LUTS +!> 2015-??-?? | S. Moorthi | threading, optimization, local dimension +!> 2019-07-24 | Li(Kate) Zhang | Merge and update ARAH Lu's work from NGAC into FV3-Chem +!> 2019-10-30 | Bo Cui | Remove "GOTO" statement +!> 2020-03-25 | Jesse Meng | Remove grib1 +!> 2020-05-20 | Jesse Meng | CALRH unification with NAM scheme +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-02-08 | Anning Cheng | read aod550, aod550_du/su/ss/oc/bc directly from fv3gfs and output to grib2 by setting rdaod +!> 2021-04-01 | Jesse Meng | Computation on defined points only +!> +!> @author Russ Treadon W/NP2 @date 1993-08-30 SUBROUTINE CLDRAD ! @@ -107,18 +78,19 @@ SUBROUTINE CLDRAD HBOT, HBOTD, HBOTS, HTOP, HTOPD, HTOPS, FIS, PBLH, & PBOT, PBOTL, PBOTM, PBOTH, CNVCFR, PTOP, PTOPL, & PTOPM, PTOPH, TTOPL, TTOPM, TTOPH, PBLCFR, CLDWORK, & - ASWIN, AUVBIN, AUVBINC, ASWIN, ASWOUT,ALWOUT, ASWTOA,& + ASWIN, AUVBIN, AUVBINC, ASWOUT,ALWOUT, ASWTOA, & RLWTOA, CZMEAN, CZEN, RSWIN, ALWIN, ALWTOA, RLWIN, & SIGT4, RSWOUT, RADOT, RSWINC, ASWINC, ASWOUTC, & ASWTOAC, ALWOUTC, ASWTOAC, AVISBEAMSWIN, & - AVISDIFFSWIN, ASWINTOA, ASWINC, ASWTOAC, AIRBEAMSWIN,& + AVISDIFFSWIN, ASWINTOA, ASWTOAC, AIRBEAMSWIN, & AIRDIFFSWIN, DUSMASS, DUSMASS25, DUCMASS, DUCMASS25, & ALWINC, ALWTOAC, SWDDNI, SWDDIF, SWDNBC, SWDDNIC, & SWDDIFC, SWUPBC, LWDNBC, LWUPBC, SWUPT, & TAOD5502D, AERSSA2D, AERASY2D, MEAN_FRP, LWP, IWP, & AVGCPRATE, & DUSTCB,SSCB,BCCB,OCCB,SULFCB,DUSTPM,SSPM,aod550, & - du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 + du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550, & + PWAT,DUSTPM10,MAOD use masks, only: LMH, HTM use params_mod, only: TFRZ, D00, H99999, QCLDMIN, SMALL, D608, H1, ROG, & GI, RD, QCONV, ABSCOEFI, ABSCOEF, STBOL, PQ0, A2, & @@ -127,7 +99,7 @@ SUBROUTINE CLDRAD FLD_INFO, AVRAIN, THEAT, IFHR, IFMIN, AVCNVC, & TCLOD, ARDSW, TRDSW, ARDLW, NBIN_DU, TRDLW, IM, & NBIN_SS, NBIN_OC, NBIN_BC, NBIN_SU, DTQ2, & - JM, LM, gocart_on, me, rdaod + JM, LM, gocart_on, me, rdaod,ISTA, IEND use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use gridspec_mod, only: dyval, gridtype use cmassi_mod, only: TRAD_ice @@ -144,10 +116,10 @@ SUBROUTINE CLDRAD ! ! LOGICAL,dimension(im,jm) :: NEED INTEGER :: lcbot,lctop,jc,ic !bsf - INTEGER,dimension(im,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & + INTEGER,dimension(ista:iend,jsta:jend) :: IBOTT, IBOTCu, IBOTDCu, IBOTSCu, IBOTGr, & ITOPT, ITOPCu, ITOPDCu, ITOPSCu, ITOPGr REAL,dimension(im,jm) :: GRID1 - REAL,dimension(im,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & + REAL,dimension(ista:iend,jsta:jend) :: GRID2, EGRID1, EGRID2, EGRID3, & CLDP, CLDZ, CLDT, CLDZCu REAL,dimension(lm) :: RHB, watericetotal, pabovesfc REAL :: watericemax, wimin, zcldbase, zcldtop, zpbltop, & @@ -164,7 +136,7 @@ SUBROUTINE CLDRAD real,dimension(im,jm) :: ceil ! B ZHOU: For aviation: - REAL, dimension(im,jsta:jend) :: TCLD, CEILING + REAL, dimension(ista:iend,jsta:jend) :: TCLD, CEILING real CU_ir(LM), q_conv !bsf !jw integer I,J,L,K,IBOT,ITCLOD,LBOT,LTOP,ITRDSW,ITRDLW, & @@ -175,8 +147,9 @@ SUBROUTINE CLDRAD real FULL_CLD(IM,JM) !-- Must be dimensioned for the full domain real, allocatable :: full_ceil(:,:), full_fis(:,:) ! - real dummy(IM,jsta:jend) - integer idummy(IM,jsta:jend) + real dummy(ista:iend,jsta:jend) + integer idummy(ista:iend,jsta:jend) + real full_dummy(im,jm) ! ! --- Revision added for GOCART --- @@ -221,7 +194,7 @@ SUBROUTINE CLDRAD ! - relative humidity dependent aerosol optical properties: oc, bc, su, ss001-005 real (kind=kind_phys) :: extrhd(KRHLEV,KCM2,NBDSW) ! extinction coefficient ! - REAL,dimension(im,jsta:jend) :: P1D,T1D,Q1D,EGRID4 + REAL,dimension(ista:iend,jsta:jend) :: P1D,T1D,Q1D,EGRID4 ! REAL, allocatable :: RH3D(:,:,:) ! RELATIVE HUMIDITY real, allocatable:: rdrh(:,:,:) integer, allocatable :: ihh(:,:,:) @@ -229,10 +202,10 @@ SUBROUTINE CLDRAD INTEGER :: IH1, IH2 INTEGER :: IOS, INDX, ISSAM, ISSCM, ISUSO, IWASO, ISOOT, NBIN REAL :: CCDRY, CCWET, SSAM, SSCM - REAL,dimension(im,jsta:jend) :: AOD_DU, AOD_SS, AOD_SU, AOD_OC, AOD_BC, AOD - REAL,dimension(im,jsta:jend) :: SCA_DU, SCA_SS, SCA_SU, SCA_OC,SCA_BC, SCA2D - REAL,dimension(im,jsta:jend) :: ASY_DU, ASY_SS, ASY_SU, ASY_OC, ASY_BC,ASY2D - REAL,dimension(im,jsta:jend) :: ANGST, AOD_440, AOD_860 ! FORANGSTROM EXPONENT + REAL,dimension(ista:iend,jsta:jend) :: AOD_DU, AOD_SS, AOD_SU, AOD_OC, AOD_BC, AOD + REAL,dimension(ista:iend,jsta:jend) :: SCA_DU, SCA_SS, SCA_SU, SCA_OC,SCA_BC, SCA2D + REAL,dimension(ista:iend,jsta:jend) :: ASY_DU, ASY_SS, ASY_SU, ASY_OC, ASY_BC,ASY2D + REAL,dimension(ista:iend,jsta:jend) :: ANGST, AOD_440, AOD_860 ! FORANGSTROM EXPONENT REAL :: ANG1, ANG2 INTEGER :: INDX_EXT(nAero), INDX_SCA(nAero) LOGICAL :: LAEROPT, LEXT, LSCA, LASY @@ -254,6 +227,7 @@ SUBROUTINE CLDRAD data INDX_EXT / 610, 611, 612, 613, 614 / data INDX_SCA / 651, 652, 653, 654, 655 / logical, parameter :: debugprint = .false. + logical :: Model_Pwat ! ! !************************************************************************* @@ -272,7 +246,7 @@ SUBROUTINE CLDRAD IF (IGET(030)>0.OR.IGET(572)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = SPVAL ENDDO ENDDO @@ -282,14 +256,14 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) + TFRZ ENDDO ENDDO @@ -299,11 +273,12 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(030)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -314,12 +289,13 @@ SUBROUTINE CLDRAD cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(572)) ! where(GRID1 /= SPVAL) GRID1 = GRID1-TFRZ -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - if (grid1(i,jj) /= spval) grid1(i,jj) = grid1(i,jj) - tfrz - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + if (grid1(ii,jj) /= spval) grid1(ii,jj) = grid1(ii,jj) - tfrz + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -343,7 +319,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -351,11 +327,12 @@ SUBROUTINE CLDRAD if(grib == "grib2" )then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(032)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -371,7 +348,7 @@ SUBROUTINE CLDRAD IF ( (LVLS(1,IGET(032)) > 0) )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -385,7 +362,7 @@ SUBROUTINE CLDRAD EGRID3,dummy,dummy) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -393,18 +370,19 @@ SUBROUTINE CLDRAD CALL BOUND(GRID1,D00,H99999) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) < SPVAL) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO if(grib == "grib2" )then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(107)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -417,21 +395,39 @@ SUBROUTINE CLDRAD IF (IGET(080) > 0) THEN ! dong GRID1 = spval - CALL CALPW(GRID1(1,jsta),1) + Model_Pwat = .false. + DO J=JSTA,JEND + DO I=ISTA,IEND + IF(ABS(PWAT(I,J)-SPVAL)>SMALL) THEN + Model_Pwat = .true. + exit + ENDIF + END DO + END DO + IF (Model_Pwat) THEN + DO J=JSTA,JEND + DO I=ISTA,IEND + GRID1(I,J) = PWAT(I,J) + END DO + END DO + ELSE + CALL CALPW(GRID1(ista:iend,jsta:jend),1) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J) >= SPVAL) GRID1(I,J)=spval END DO END DO + ENDIF CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(080)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -441,16 +437,17 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN AOD (TAOD553D FROM HRRR-SMOKE) ! IF (IGET(735) > 0) THEN - CALL CALPW(GRID1(1,jsta),19) + CALL CALPW(GRID1(ista:iend,jsta:jend),19) CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(735)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -460,16 +457,17 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN FIRE SMOKE (tracer_1a FROM HRRR-SMOKE) ! IF (IGET(736) > 0) THEN - CALL CALPW(GRID1(1,jsta),18) + CALL CALPW(GRID1(ista:iend,jsta:iend),18) CALL BOUND(GRID1,D00,H99999) if(grib == "grib2" )then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(736)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -481,18 +479,18 @@ SUBROUTINE CLDRAD GRID2 = spval IF (MODELNAME == 'RAPR') THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LWP(I,J) < SPVAL) GRID1(I,J) = LWP(I,J)/1000.0 ! use WRF-diagnosed value ENDDO ENDDO ELSE - CALL CALPW(GRID1(1,jsta),2) + CALL CALPW(GRID1(ista:iend,jsta:jend),2) IF(MODELNAME == 'GFS')then ! GFS combines cloud water and cloud ice, hoping to seperate them next implementation - CALL CALPW(GRID2(1,jsta),3) + CALL CALPW(GRID2(ista:iend,jsta:jend),3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(GRID1(I,J) 0) THEN - CALL CALPW(GRID1(1,jsta),4) + CALL CALPW(GRID1(ista:iend,jsta:jend),4) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(202)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -578,16 +580,17 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN SNOW IF (IGET(203) > 0) THEN - CALL CALPW(GRID1(1,jsta),5) + CALL CALPW(GRID1(ista:iend,jsta:jend),5) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(203)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -596,16 +599,17 @@ SUBROUTINE CLDRAD ! SRD ! TOTAL COLUMN GRAUPEL IF (IGET(428) > 0) THEN - CALL CALPW(GRID1(1,jsta),16) + CALL CALPW(GRID1(ista:iend,jsta:jend),16) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(428)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -614,16 +618,17 @@ SUBROUTINE CLDRAD ! TOTAL COLUMN CONDENSATE IF (IGET(204) > 0) THEN - CALL CALPW(GRID1(1,jsta),6) + CALL CALPW(GRID1(ista:iend,jsta:jend),6) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(204)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -631,16 +636,17 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN SUPERCOOLED (<0C) LIQUID WATER IF (IGET(285) > 0) THEN - CALL CALPW(GRID1(1,jsta),7) + CALL CALPW(GRID1(ista:iend,jsta:jend),7) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(285)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -648,16 +654,17 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN MELTING (>0C) ICE IF (IGET(286) > 0) THEN - CALL CALPW(GRID1(1,jsta),8) + CALL CALPW(GRID1(ista:iend,jsta:jend),8) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(286)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -665,15 +672,16 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN SHORT WAVE T TENDENCY IF (IGET(290) > 0) THEN - CALL CALPW(GRID1(1,jsta),9) + CALL CALPW(GRID1(ista:iend,jsta:jend),9) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(290)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -681,15 +689,16 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN LONG WAVE T TENDENCY IF (IGET(291) > 0) THEN - CALL CALPW(GRID1(1,jsta),10) + CALL CALPW(GRID1(ista:iend,jsta:jend),10) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(291)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -697,15 +706,15 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN GRID SCALE LATENT HEATING (TIME AVE) IF (IGET(292) > 0) THEN - CALL CALPW(GRID1(1,jsta),11) + CALL CALPW(GRID1(ista:iend,jsta:jend),11) IF(AVRAIN > 0.)THEN RRNUM = 1./AVRAIN ELSE RRNUM = 0. ENDIF -!$omp parallel do +!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO @@ -735,11 +744,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -747,15 +757,15 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN CONVECTIVE LATENT HEATING (TIME AVE) IF (IGET(293) > 0) THEN - CALL CALPW(GRID1(1,jsta),12) + CALL CALPW(GRID1(ista:iend,jsta:jend),12) IF(AVRAIN > 0.)THEN RRNUM = 1./AVCNVC ELSE RRNUM = 0. ENDIF -!$omp parallel do +!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(GRID1(I,J) < SPVAL) GRID1(I,J) = GRID1(I,J)*RRNUM ENDDO ENDDO @@ -785,11 +795,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -797,35 +808,36 @@ SUBROUTINE CLDRAD ! ! TOTAL COLUMN moisture convergence IF (IGET(295)>0) THEN - CALL CALPW(GRID1(1,jsta),13) + CALL CALPW(GRID1(ista:iend,jsta:jend),13) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(295)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TOTAL COLUMN RH IF (IGET(312)>0) THEN - CALL CALPW(GRID1(1,jsta),14) + CALL CALPW(GRID1(ista:iend,jsta:jend),14) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(312)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TOTAL COLUMN OZONE IF (IGET(299) > 0) THEN - CALL CALPW(GRID1(1,jsta),15) + CALL CALPW(GRID1(ista:iend,jsta:jend),15) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(299)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -834,7 +846,7 @@ SUBROUTINE CLDRAD ! BOTTOM AND/OR TOP OF SUPERCOOLED (<0C) LIQUID WATER LAYER IF (IGET(287)>0 .OR. IGET(288)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=-5000. GRID2(I,J)=-5000. !-- Search for the base first, then look for the top if supercooled liquid exists @@ -868,24 +880,25 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(287)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(288)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=GRID2(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(288)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -897,14 +910,14 @@ SUBROUTINE CLDRAD ! from 0.2 (EFIMN in cuparm in model) to 1.0 (Ferrier, Feb '02) IF (IGET(197)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDEFI(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(197)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -916,7 +929,7 @@ SUBROUTINE CLDRAD ! also a method for cloud ceiling height ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CFRACL(I,J)=0. CFRACM(I,J)=0. CFRACH(I,J)=0. @@ -933,10 +946,10 @@ SUBROUTINE CLDRAD endif DELY=14259./DY_m numr=NINT(DELY) - ! write (0,*) 'numr,dyval,DY_m=',numr,dyval,DY_m + write (0,*) 'numr,dyval,DY_m=',numr,dyval,DY_m DO L=LM,1,-1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(CFR(I,J,L)=PTOP_LOW) THEN @@ -1019,9 +1035,9 @@ SUBROUTINE CLDRAD ! GSD maximum cloud fraction in (PBL + 1 km) (J. Kenyon, 8 Aug 2019) IF (IGET(799)>0) THEN -!$omp parallel do private(i,j) +!$omp parallel do private(i,j,k) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=0.0 DO K = 1,LM IF (ZMID(I,J,LM-K+1) <= PBLH(I,J)+1000.0) THEN @@ -1033,7 +1049,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(799)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1041,7 +1057,7 @@ SUBROUTINE CLDRAD IF (IGET(037) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CFRACL(I,J) < SPVAL) then GRID1(I,J) = CFRACL(I,J)*100. else @@ -1052,11 +1068,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(037)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1066,7 +1083,7 @@ SUBROUTINE CLDRAD IF (IGET(300) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCFRACL(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACL(I,J)*100. else @@ -1102,11 +1119,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1117,7 +1135,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CFRACM(I,J) < SPVAL) then GRID1(I,J) = CFRACM(I,J)*100. else @@ -1128,11 +1146,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(038)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1142,7 +1161,7 @@ SUBROUTINE CLDRAD IF (IGET(301) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(AVGCFRACM(I,J)-SPVAL)>SMALL)THEN GRID1(I,J) = AVGCFRACM(I,J)*100. ELSE @@ -1178,11 +1197,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1193,7 +1213,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CFRACH(I,J) < SPVAL) then GRID1(I,J) = CFRACH(I,J)*100. else @@ -1204,11 +1224,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(039)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1219,7 +1240,7 @@ SUBROUTINE CLDRAD ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCFRACH(I,J) < SPVAL) then GRID1(I,J) = AVGCFRACH(I,J)*100. else @@ -1255,11 +1276,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1271,7 +1293,7 @@ SUBROUTINE CLDRAD IF(MODELNAME=='NCAR' .OR. MODELNAME=='RAPR')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(i,j) = SPVAL egrid1(i,j)=0. do l = 1,LM @@ -1283,7 +1305,7 @@ SUBROUTINE CLDRAD ELSE IF (MODELNAME=='NMM'.OR.MODELNAME=='FV3R' & .OR. MODELNAME=='GFS')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! EGRID1(I,J)=AMAX1(CFRACL(I,J), ! 1 AMAX1(CFRACM(I,J),CFRACH(I,J))) ! EGRID1(I,J)=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))* & @@ -1295,7 +1317,7 @@ SUBROUTINE CLDRAD END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(EGRID1(I,J)-SPVAL) > SMALL) THEN GRID1(I,J) = EGRID1(I,J)*100. TCLD(I,J) = EGRID1(I,J)*100. !B ZHOU, PASSED to CALCEILING @@ -1306,11 +1328,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(161)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1323,7 +1346,7 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(AVGTCDC(I,J)-SPVAL) > SMALL) then GRID1(I,J) = AVGTCDC(I,J)*100. else @@ -1334,7 +1357,7 @@ SUBROUTINE CLDRAD ELSE IF(MODELNAME == 'NMM')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! RSUM = NCFRST(I,J)+NCFRCV(I,J) ! IF (RSUM>0.0) THEN ! EGRID1(I,J)=(ACFRST(I,J)+ACFRCV(I,J))/RSUM @@ -1385,11 +1408,12 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1401,7 +1425,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (NCFRST(I,J)0.0) THEN GRID1(I,J) = ACFRST(I,J)/NCFRST(I,J)*100. @@ -1443,7 +1467,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1453,7 +1477,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (NCFRCV(I,J)0.0) THEN GRID1(I,J) = ACFRCV(I,J)/NCFRCV(I,J)*100. @@ -1495,7 +1519,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1513,7 +1537,7 @@ SUBROUTINE CLDRAD !--- Rain is not part of cloud, only cloud water + cloud ice + snow ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! !--- Various convective cloud base & cloud top levels ! @@ -1644,14 +1668,14 @@ SUBROUTINE CLDRAD IF (IGET(758)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZCu(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(758)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1663,7 +1687,7 @@ SUBROUTINE CLDRAD ! IF ((IGET(148)>0) .OR. (IGET(178)>0) .OR.(IGET(260)>0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IBOT=IBOTT(I,J) !-- Cloud base ("bottoms") IF(MODELNAME == 'RAPR') then IF (IBOT <= 0) THEN @@ -1694,28 +1718,28 @@ SUBROUTINE CLDRAD ! CLOUD BOTTOM PRESSURE IF (IGET(148)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDP(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(148)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! CLOUD BOTTOM HEIGHT IF (IGET(178)>0) THEN !--- Parameter was set to 148 in operational code (Ferrier, Feb '02) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(178)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1744,7 +1768,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND !- imported from RUC post CLDZ(I,J) = SPVAL pcldbase = SPVAL @@ -1929,7 +1953,7 @@ SUBROUTINE CLDRAD nlifr = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND zcld = CLDZ(i,j) - FIS(I,J)*GI if (CLDZ(i,j)>=0..and.zcld<160.) nlifr = nlifr+1 end do @@ -1940,14 +1964,14 @@ SUBROUTINE CLDRAD IF (IGET(408)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(408)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF !End of GSD algorithm @@ -1965,7 +1989,7 @@ SUBROUTINE CLDRAD ceiling_thresh_cldfra = 0.5 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ceil(I,J) = SPVAL zceil = SPVAL cldfra_max = 0. @@ -2031,14 +2055,14 @@ SUBROUTINE CLDRAD ! Parameter 487: experimental ceiling diagnostic #1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ceil(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(487)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! end of parameter-487 conditional code ! END OF EXPERIMENTAL GSD CEILING DIAGNOSTIC 1 @@ -2062,7 +2086,7 @@ SUBROUTINE CLDRAD const1 = 3.912 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ceil(I,J) = SPVAL zceil = SPVAL zceil1 = SPVAL @@ -2180,16 +2204,23 @@ SUBROUTINE CLDRAD ! layer. allocate(full_ceil(IM,JM),full_fis(IM,JM)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND full_ceil(i,j)=ceil(i,j) full_fis(i,j)=fis(i,j) ENDDO ENDDO - CALL AllGETHERV(full_ceil) - CALL AllGETHERV(full_fis) +! CALL AllGETHERV(full_ceil) + full_dummy=spval + CALL COLLECT_ALL(full_ceil(ISTA:IEND,JSTA:JEND),full_dummy) + full_ceil=full_dummy +! CALL AllGETHERV(full_fis) + full_dummy=spval + CALL COLLECT_ALL(full_fis(ISTA:IEND,JSTA:JEND),full_dummy) + full_fis=full_dummy + numr = 1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ceil_min = max( ceil(I,J)-FIS(I,J)*GI , 5.0) ! ceil_min in AGL do jc = max(1,J-numr),min(JM,J+numr) do ic = max(1,I-numr),min(IM,I+numr) @@ -2217,14 +2248,14 @@ SUBROUTINE CLDRAD IF (IGET(711)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(711)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -2232,14 +2263,14 @@ SUBROUTINE CLDRAD IF (IGET(798)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDP(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(798)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF ! end of parameter-711 and -798 conditional code @@ -2250,32 +2281,33 @@ SUBROUTINE CLDRAD IF (IGET(260)>0) THEN CALL CALCEILING(CLDZ,TCLD,CEILING) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CEILING(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(260)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! B. ZHOU: FLIGHT CONDITION RESTRICTION IF (IGET(261) > 0) THEN CALL CALFLTCND(CEILING,GRID1(1,jsta)) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! GRID1(I,J) = FLTCND(I,J) ! ENDDO ! ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(261)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2287,13 +2319,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PBOT(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IBOT=IBOTCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2306,11 +2338,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(188)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2320,7 +2353,7 @@ SUBROUTINE CLDRAD ! IF (IGET(192) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IBOT=IBOTDCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2332,14 +2365,14 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(192)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- Shallow convective cloud base pressures (Ferrier, Feb '02) ! IF (IGET(190) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IBOT=IBOTSCu(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2351,14 +2384,14 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(190)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- Base of grid-scale cloudiness (Ferrier, Feb '02) ! IF (IGET(194) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IBOT=IBOTGr(I,J) IF (IBOT>0 .AND. IBOT<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,IBOT) @@ -2370,7 +2403,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(194)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -2378,7 +2411,7 @@ SUBROUTINE CLDRAD ! IF (IGET(303) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! IF(PBOTL(I,J) > SMALL)THEN GRID1(I,J) = PBOTL(I,J) ! ELSE @@ -2414,14 +2447,14 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- Base of middle cloud ! IF (IGET(306) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(PBOTM(I,J) > SMALL)THEN GRID1(I,J) = PBOTM(I,J) ELSE @@ -2457,14 +2490,14 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- Base of high cloud ! IF (IGET(309) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(PBOTH(I,J) > SMALL)THEN GRID1(I,J) = PBOTH(I,J) ELSE @@ -2500,7 +2533,7 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -2513,7 +2546,7 @@ SUBROUTINE CLDRAD IF ((IGET(149)>0) .OR. (IGET(179)>0) .OR. & (IGET(168)>0) .OR. (IGET(275)>0)) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ITOP=ITOPT(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN IF(T(I,J,ITOP)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDP(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(149)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! CLOUD TOP HEIGHT ! IF (IGET(179)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(179)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -2581,7 +2614,7 @@ SUBROUTINE CLDRAD Cloud_def_p = 0.0000001 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! imported from RUC post ! Cloud top zcldtop = -5000. @@ -2645,28 +2678,28 @@ SUBROUTINE CLDRAD ! IF (IGET(406)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDP(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(406)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! GSD CLOUD TOP HEIGHT ! IF (IGET(409)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDZ(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(409)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF ! end of GSD algorithm @@ -2675,14 +2708,14 @@ SUBROUTINE CLDRAD ! IF (IGET(168)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = CLDT(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(168)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -2691,7 +2724,7 @@ SUBROUTINE CLDRAD num_thick=0 ! for debug GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND opdepth=0. llmh=nint(lmh(i,j)) !bsf - start @@ -2783,7 +2816,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(275)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -2794,13 +2827,13 @@ SUBROUTINE CLDRAD IF(MODELNAME == 'GFS')THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PTOP(I,J) ENDDO ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ITOP=ITOPCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2813,11 +2846,12 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(189)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2827,7 +2861,7 @@ SUBROUTINE CLDRAD ! IF (IGET(193) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ITOP=ITOPDCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2839,14 +2873,14 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(193)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Shallow convective cloud top pressures (Ferrier, Feb '02) ! IF (IGET(191) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ITOP=ITOPSCu(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2858,7 +2892,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(191)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF ! @@ -2866,7 +2900,7 @@ SUBROUTINE CLDRAD ! IF (IGET(195) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ITOP=ITOPGr(I,J) IF (ITOP>0 .AND. ITOP<=NINT(LMH(I,J))) THEN GRID1(I,J) = PMID(I,J,ITOP) @@ -2878,7 +2912,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(195)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF @@ -2886,7 +2920,7 @@ SUBROUTINE CLDRAD ! IF (IGET(304) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(PTOPL(I,J) > SMALL)THEN GRID1(I,J) = PTOPL(I,J) ELSE @@ -2922,14 +2956,14 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- top of middle cloud ! IF (IGET(307) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PTOPM(I,J) ENDDO ENDDO @@ -2961,14 +2995,14 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- top of high cloud ! IF (IGET(310) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PTOPH(I,J) ENDDO ENDDO @@ -3000,7 +3034,7 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3008,7 +3042,7 @@ SUBROUTINE CLDRAD ! IF (IGET(305) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TTOPL(I,J) ENDDO ENDDO @@ -3040,14 +3074,14 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- Base of middle cloud ! IF (IGET(308) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TTOPM(I,J) ENDDO ENDDO @@ -3079,14 +3113,14 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- Base of high cloud ! IF (IGET(311) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TTOPH(I,J) ENDDO ENDDO @@ -3117,7 +3151,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=1 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3126,7 +3160,7 @@ SUBROUTINE CLDRAD IF (IGET(196) > 0.or.IGET(570)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(CNVCFR(I,J)/=SPVAL)GRID1(I,J)=100.*CNVCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3134,13 +3168,13 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(196)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif elseif(IGET(570)>0) then if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(570)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif endif END IF @@ -3150,7 +3184,7 @@ SUBROUTINE CLDRAD IF (IGET(342) > 0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(PBLCFR(I,J)/=SPVAL)GRID1(I,J)=100.*PBLCFR(I,J) !-- convert to percent ENDDO ENDDO @@ -3182,7 +3216,7 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF ! @@ -3190,7 +3224,7 @@ SUBROUTINE CLDRAD ! IF (IGET(313) > 0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=cldwork(I,J) ENDDO ENDDO @@ -3222,7 +3256,7 @@ SUBROUTINE CLDRAD endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF ! @@ -3242,7 +3276,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ASWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ASWIN(I,J)*RRNUM ELSE @@ -3278,7 +3312,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3295,7 +3329,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AUVBIN(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBIN(I,J)*RRNUM ELSE @@ -3332,7 +3366,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3349,7 +3383,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AUVBINC(I,J)/=SPVAL)THEN GRID1(I,J) = AUVBINC(I,J)*RRNUM ELSE @@ -3386,7 +3420,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3402,7 +3436,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ALWIN(I,J)/=SPVAL)THEN GRID1(I,J) = ALWIN(I,J)*RRNUM ELSE @@ -3438,7 +3472,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3454,7 +3488,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ASWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ASWOUT(I,J)*RRNUM ELSE @@ -3490,7 +3524,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3506,7 +3540,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ALWOUT(I,J)/=SPVAL)THEN GRID1(I,J) = -1.0*ALWOUT(I,J)*RRNUM ELSE @@ -3542,7 +3576,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3558,7 +3592,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ASWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ASWTOA(I,J)*RRNUM ELSE @@ -3594,7 +3628,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3610,7 +3644,7 @@ SUBROUTINE CLDRAD RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ALWTOA(I,J)/=SPVAL)THEN GRID1(I,J) = ALWTOA(I,J)*RRNUM ELSE @@ -3646,7 +3680,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3656,7 +3690,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RLWTOA(I,J) ENDDO ENDDO @@ -3664,7 +3698,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(274)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3675,7 +3709,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RLWTOA(I,J) < SPVAL) & & GRID1(I,J) = (RLWTOA(I,J)*STBOL)**0.25 ENDDO @@ -3684,7 +3718,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(265)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3692,7 +3726,7 @@ SUBROUTINE CLDRAD IF (IGET(156)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RSWIN(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) @@ -3707,7 +3741,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(156)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3716,7 +3750,7 @@ SUBROUTINE CLDRAD ! dong add missing value to DLWRF GRID1 = spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(MODELNAME=='RSM' .OR. MODELNAME == 'RAPR') THEN !add by Binbin: RSM has direct RLWIN output GRID1(I,J)=RLWIN(I,J) ELSE @@ -3737,7 +3771,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(157)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3746,7 +3780,7 @@ SUBROUTINE CLDRAD GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RSWOUT(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) @@ -3761,21 +3795,21 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(141)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous clear-sky upwelling SW at the surface IF (IGET(743)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWUPBC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(743)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3783,42 +3817,42 @@ SUBROUTINE CLDRAD IF (IGET(142)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RADOT(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(142)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous clear-sky downwelling LW at the surface IF (IGET(744)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = LWDNBC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(744)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous clear-sky upwelling LW at the surface IF (IGET(745)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = LWUPBC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(745)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3826,7 +3860,7 @@ SUBROUTINE CLDRAD IF (IGET(740)>0) THEN ! print *,"GETTING INTO MEAN_FRP PART" DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = MEAN_FRP(I,J) ENDDO ENDDO @@ -3834,7 +3868,7 @@ SUBROUTINE CLDRAD ! print *,"GETTING INTO MEAN_FRP GRIB2 PART" cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(740)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3843,7 +3877,7 @@ SUBROUTINE CLDRAD GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RSWINC(I,J)1.E-6) THEN FACTRS=CZEN(I,J)/CZMEAN(I,J) @@ -3857,21 +3891,21 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(262)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous clear-sky downwelling SW at surface (GSD version) IF (IGET(742)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWDNBC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(742)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3879,28 +3913,28 @@ SUBROUTINE CLDRAD IF (IGET(772)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWDDNI(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(772)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous clear-sky SWDDNI IF (IGET(796)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWDDNIC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(796)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3908,35 +3942,35 @@ SUBROUTINE CLDRAD IF (IGET(773)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWDDIF(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(773)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous clear-sky SWDDIF IF (IGET(797)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWDDIFC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(797)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! TIME AVERAGED INCOMING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(383)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ASWINC(I,J) ENDDO ENDDO @@ -3967,14 +4001,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE SURFACE. IF (IGET(386)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ASWOUTC(I,J) ENDDO ENDDO @@ -4005,28 +4039,28 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Instantaneous all-sky outgoing SW flux at the model top IF (IGET(719)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWUPT(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(719)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! TIME AVERAGED OUTGOING CLEARSKY SW RADIATION AT THE MODEL TOP IF (IGET(387)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ASWTOAC(I,J) ENDDO ENDDO @@ -4057,14 +4091,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED INCOMING SW RADIATION AT THE MODEL TOP IF (IGET(388)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ASWINTOA(I,J) ENDDO ENDDO @@ -4095,14 +4129,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED INCOMING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(382)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ALWINC(I,J) ENDDO ENDDO @@ -4133,14 +4167,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE SURFACE IF (IGET(384)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ALWOUTC(I,J) ENDDO ENDDO @@ -4171,14 +4205,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED OUTGOING CLEARSKY LW RADIATION AT THE MODEL TOP IF (IGET(385)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ALWTOAC(I,J) ENDDO ENDDO @@ -4209,14 +4243,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(401)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = AVISBEAMSWIN(I,J) ENDDO ENDDO @@ -4249,14 +4283,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(402)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = AVISDIFFSWIN(I,J) ENDDO ENDDO @@ -4288,14 +4322,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED SURFACE VISIBLE BEAM DOWNWARD SOLAR FLUX IF (IGET(403)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = AIRBEAMSWIN(I,J) ENDDO ENDDO @@ -4327,14 +4361,14 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! TIME AVERAGED SURFACE VISIBLE DIFFUSE DOWNWARD SOLAR FLUX IF (IGET(404)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = AIRDIFFSWIN(I,J) ENDDO ENDDO @@ -4366,7 +4400,7 @@ SUBROUTINE CLDRAD fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -4374,80 +4408,80 @@ SUBROUTINE CLDRAD IF(rdaod) then IF (IGET(609).GT.0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=aod550(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(609)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(610).GT.0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=du_aod550(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(610)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(611).GT.0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=ss_aod550(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(611)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(612).GT.0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=su_aod550(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(612)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(613).GT.0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=oc_aod550(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(613)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(614).GT.0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=bc_aod550(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(614)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF END IF !rdaod @@ -4455,42 +4489,42 @@ SUBROUTINE CLDRAD !2D AEROSOL OPTICAL DEPTH AT 550 NM IF (IGET(715)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=taod5502d(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(715)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !AEROSOL ASYMMETRY FACTOR IF (IGET(716)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=aerasy2d(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(716)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !AEROSOL SINGLE-SCATTERING ALBEDO IF (IGET(717)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND grid1(i,j)=aerssa2d(i,j) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(717)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -4676,14 +4710,14 @@ SUBROUTINE CLDRAD CLOSE(UNIT=NOAER) !!! COMPUTES RELATIVE HUMIDITY AND RDRH -! allocate (RH3D(im,jsta:jend,lm)) - allocate (rdrh(im,jsta:jend,lm)) - allocate (ihh(im,jsta:jend,lm)) +! allocate (RH3D(ista:iend,jsta:jend,lm)) + allocate (rdrh(ista:iend,jsta:jend,lm)) + allocate (ihh(ista:iend,jsta:jend,lm)) DO L=1,LM ! L FROM TOA TO SFC LL=LM-L+1 ! LL FROM SFC TO TOA !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND P1D(I,J) = PMID(I,J,LL) T1D(I,J) = T(I,J,LL) Q1D(I,J) = Q(I,J,LL) @@ -4691,7 +4725,7 @@ SUBROUTINE CLDRAD ENDDO CALL CALRH(P1D,T1D,Q1D,EGRID4) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! RH3D(I,J,LL) = EGRID4(I,J) RH3D = EGRID4(I,J) ! DETERMINE RDRH (wgt for IH2) and IHH (index for IH2) @@ -4779,7 +4813,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DO L=1,LM DO N=1, NBIN_DU EXT01 = EXTRHD_DU(1,N,IB) @@ -4806,7 +4840,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DO L=1,LM ih1 = ihh(I,J,L) ih2 = ih1 + 1 @@ -4840,7 +4874,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4873,7 +4907,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4905,7 +4939,7 @@ SUBROUTINE CLDRAD SCA=0.0 ASY=0.0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DO L=1,LM ih1 = ihh (I,J,L) ih2 = ih1 + 1 @@ -4935,7 +4969,7 @@ SUBROUTINE CLDRAD SCA=SPVAL ASY=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND AOD_DU(I,J) = MAX (AOD_DU(I,J), 0.0) AOD_BC(I,J) = MAX (AOD_BC(I,J), 0.0) AOD_OC(I,J) = MAX (AOD_OC(I,J), 0.0) @@ -4967,7 +5001,7 @@ SUBROUTINE CLDRAD IF (IB == 2 ) THEN !! AOD AT 440 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND AOD_440(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4976,7 +5010,7 @@ SUBROUTINE CLDRAD IF (IB == 5 ) THEN !! AOD AT 860 NM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND AOD_860(I,J) = AOD(I,J) ENDDO ! I-loop ENDDO ! J-loop @@ -4987,7 +5021,7 @@ SUBROUTINE CLDRAD IF ( IGET(INDX) > 0) THEN !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend GRID1(i,j) = AOD(i,j) enddo enddo @@ -4995,7 +5029,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(INDX)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5007,7 +5041,7 @@ SUBROUTINE CLDRAD GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SCA2D(I,J) 0.0 ) THEN ASY2D(I,J) = ASY2D(I,J) / SCA2D(I,J) @@ -5022,7 +5056,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(649)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! IGET(649) @@ -5031,7 +5065,7 @@ SUBROUTINE CLDRAD GRID1 = SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AOD(I,J) 0.0 ) THEN SCA2D(I,J) = SCA2D(I,J) / AOD(I,J) @@ -5046,7 +5080,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(648)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! IGET(648) ! print *,'aft compute sca340' @@ -5062,7 +5096,7 @@ SUBROUTINE CLDRAD IF ( IGET(650) > 0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=SCA2D(I,J) ENDDO ENDDO @@ -5070,7 +5104,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(650)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! LOOP THROUGH EACH SPECIES @@ -5081,7 +5115,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! EXT AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF ( II == 1 ) GRID1(I,J) = AOD_DU(I,J) IF ( II == 2 ) GRID1(I,J) = AOD_SS(I,J) IF ( II == 3 ) GRID1(I,J) = AOD_SU(I,J) @@ -5093,7 +5127,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(JJ)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -5102,7 +5136,7 @@ SUBROUTINE CLDRAD IF ( IGET(JJ) > 0) THEN ! SCA AOD !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF ( II == 1 ) GRID1(I,J) = SCA_DU(I,J) IF ( II == 2 ) GRID1(I,J) = SCA_SS(I,J) IF ( II == 3 ) GRID1(I,J) = SCA_SU(I,J) @@ -5114,7 +5148,7 @@ SUBROUTINE CLDRAD if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(JJ)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -5129,9 +5163,9 @@ SUBROUTINE CLDRAD ANGST=SPVAL ! ANG2 = LOG ( 0.860 / 0.440 ) ANG2 = LOG ( 860. / 440. ) -!$omp parallel do private(i,j) +!$omp parallel do private(i,j,ang1) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (AOD_860(I,J) > 0.) THEN ANG1 = LOG( AOD_440(I,J)/AOD_860(I,J) ) ANGST(I,J) = ANG1 / ANG2 @@ -5139,13 +5173,13 @@ SUBROUTINE CLDRAD GRID1(I,J)=ANGST(I,J) ENDDO ENDDO - if(debugprint)print *,'output angstrom exp,angst=',maxval(angst(1:im,jsta:jend)), & - minval(angst(1:im,jsta:jend)) + if(debugprint)print *,'output angstrom exp,angst=',maxval(angst(ista:iend,jsta:jend)), & + minval(angst(ista:iend,jsta:jend)) CALL BOUND(GRID1,D00,H99999) if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(656)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ANGSTROM EXPONENT @@ -5156,7 +5190,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND IF(DUEM(I,J,1)0) THEN + GRID1=SPVAL +!$omp parallel do private(i,j) + DO J = JSTA,JEND + DO I = ISTA,IEND + IF(BCEM(I,J,1)0) THEN + GRID1=SPVAL +!$omp parallel do private(i,j) + DO J = JSTA,JEND + DO I = ISTA,IEND + GRID1(I,J) = MAOD(I,J) + END DO + END DO + if(grib=='grib2') then + cfld=cfld+1 + fld_info(cfld)%ifld=IAVBLFLD(IGET(699)) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !! ADD DUST DRY DEPOSITION FLUXES (kg/m2/sec) ! ! IF (IGET(661)>0) THEN ! DO J = JSTA,JEND -! DO I = 1,IM +! DO I = ISTA,IEND ! GRID1(I,J) = DUDP(I,J,1)*1.E-6 ! DO K=2,NBIN_DU ! GRID1(I,J) = GRID1(I,J)+ DUDP(I,J,K)*1.E-6 @@ -5207,7 +5276,7 @@ SUBROUTINE CLDRAD ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(661)) -! datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) +! datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) ! endif ! ENDIF @@ -5215,7 +5284,7 @@ SUBROUTINE CLDRAD IF (IGET(686)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSTPM(I,J) !ug/m3 END DO @@ -5223,14 +5292,28 @@ SUBROUTINE CLDRAD if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(686)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF + IF (IGET(685)>0 ) THEN +!$omp parallel do private(i,j) + DO J = JSTA,JEND + DO I = ISTA,IEND + GRID1(I,J) = DUSTPM10(I,J) !ug/m3 + END DO + END DO + if(grib=='grib2') then + cfld=cfld+1 + fld_info(cfld)%ifld=IAVBLFLD(IGET(685)) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) + endif + ENDIF + !! ADD DUST WET DEPOSITION FLUXES (kg/m2/sec) ! IF (IGET(662)>0) THEN ! DO J = JSTA,JEND -! DO I = 1,IM +! DO I = ISTA,IEND ! GRID1(I,J) = DUWT(I,J,1)*1.E-6 ! DO K=2,NBIN_DU ! GRID1(I,J) = GRID1(I,J)+ DUWT(I,J,K)*1.E-6 @@ -5244,7 +5327,7 @@ SUBROUTINE CLDRAD ! elseif(grib=='grib2') then ! cfld=cfld+1 ! fld_info(cfld)%ifld=IAVBLFLD(IGET(662)) -! datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) +! datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) ! endif ! ENDIF @@ -5252,7 +5335,7 @@ SUBROUTINE CLDRAD IF (IGET(684)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = SSPM(I,J) !ug/m3 END DO @@ -5260,14 +5343,14 @@ SUBROUTINE CLDRAD if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(684)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !! ADD AEROSOL SURFACE PM10 MASS CONCENTRATION (ug/m3) IF (IGET(619)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND !GRID1(I,J) = DUSMASS(I,J) * 1.E-6 GRID1(I,J) = DUSMASS(I,J) !ug/m3 END DO @@ -5275,7 +5358,7 @@ SUBROUTINE CLDRAD if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(619)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -5283,7 +5366,7 @@ SUBROUTINE CLDRAD IF (IGET(620)>0 ) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND !GRID1(I,J) = DUSMASS25(I,J) * 1.E-6 GRID1(I,J) = DUSMASS25(I,J) ! ug/m3 END DO @@ -5291,7 +5374,7 @@ SUBROUTINE CLDRAD if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(620)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !! ADD TOTAL AEROSOL PM10 COLUMN DENSITY (kg/m2) ! @@ -5299,7 +5382,7 @@ SUBROUTINE CLDRAD GRID1=SPVAL !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND !GRID1(I,J) = DUCMASS(I,J) * 1.E-6 IF(DUCMASS(I,J)0) call wrt_aero_diag(674,nbin_oc,ocwt) IF (IGET(682)>0) call wrt_aero_diag(682,nbin_oc,ocsv) ! print *,'aft wrt disg ocwt' - +!! wrt MIE AOD at 550nm + IF (IGET(699).GT.0) call wrt_aero_diag(699,1,maod) + print *,'aft wrt disg maod' + !! wrt SU diag field ! IF (IGET(675)>0) call wrt_aero_diag(675,nbin_su,suem) ! IF (IGET(676)>0) call wrt_aero_diag(676,nbin_su,susd) @@ -5454,7 +5540,7 @@ SUBROUTINE CLDRAD ! CB cover is derived from CPRAT (same as #272 in SURFCE.f) EGRID1 = SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(AVGCPRATE(I,J) /= SPVAL) then EGRID1(I,J) = AVGCPRATE(I,J)*(1000./DTQ2) end if @@ -5468,7 +5554,7 @@ SUBROUTINE CLDRAD EGRID3 = SPVAL IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(I,J) = PBOT(I,J) EGRID3(I,J) = PTOP(I,J) END DO @@ -5477,7 +5563,7 @@ SUBROUTINE CLDRAD ! Derive CB base and top, relationship among CB fields DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(EGRID1(I,J)<= 0. .or. EGRID2(I,J)<= 0. .or. EGRID3(I,J) <= 0.) then EGRID1(I,J) = SPVAL EGRID2(I,J) = SPVAL @@ -5486,7 +5572,7 @@ SUBROUTINE CLDRAD END DO END DO DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID2(I,J) == SPVAL .or. EGRID3(I,J) == SPVAL) cycle if(EGRID3(I,J) < 400.*100. .and. & (EGRID2(I,J)-EGRID3(I,J)) > 300.*100) then @@ -5535,17 +5621,18 @@ SUBROUTINE CLDRAD IF(IGET(473) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(473)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo END IF @@ -5553,17 +5640,18 @@ SUBROUTINE CLDRAD IF(IGET(474) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(474)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo END IF @@ -5571,17 +5659,18 @@ SUBROUTINE CLDRAD IF(IGET(475) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(475)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo END IF @@ -5594,12 +5683,12 @@ SUBROUTINE CLDRAD END subroutine cb_cover(cbcov) -! Calculate CB coverage by using fuzzy logic -! Evaluate membership of val in a fuzzy set fuzzy. -! Assume f is in x-log scale - use ctlblk_mod, only: SPVAL,JSTA,JEND,IM +!> Calculate CB coverage by using fuzzy logic +!> Evaluate membership of val in a fuzzy set fuzzy. +!> Assume f is in x-log scale + use ctlblk_mod, only: SPVAL,JSTA,JEND,IM,ISTA,IEND implicit none - real, intent(inout) :: cbcov(IM,JSTA:JEND) + real, intent(inout) :: cbcov(ISTA:IEND,JSTA:JEND) ! x - convective precipitation [1.0e6*kg/(m2s)] ! y - cloud cover fraction, between 0 and 1 @@ -5619,7 +5708,7 @@ subroutine cb_cover(cbcov) x = log(x) do j = jsta, jend - do i = 1, IM + do i = ista, iend if(cbcov(i,j) == SPVAL) cycle if(cbcov(i,j) <= 0.) then cbcov(i,j) = 0. @@ -5650,20 +5739,20 @@ end subroutine cb_cover subroutine wrt_aero_diag(igetfld,nbin,data) use ctlblk_mod, only: jsta, jend, SPVAL, im, jm, grib, & - cfld, datapd, fld_info, jsta_2l, jend_2u + cfld, datapd, fld_info, jsta_2l, jend_2u,ista_2l,iend_2u,ista,iend use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD implicit none ! integer igetfld,nbin - real, dimension(1:im,jsta_2l:jend_2u,nbin) :: data + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,nbin) :: data ! integer i,j,k REAL,dimension(im,jm) :: GRID1 ! GRID1=SPVAL -!$omp parallel do private(i,j) +!$omp parallel do private(i,j,k) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND if(data(I,J,1) @file -! -!> SUBPROGRAM: COLLECT GATHERS FROM ALL MPI TASKS -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! GATHER "A" FROM ALL MPI TASKS ONTO TASK 0 -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! -!! USAGE: CALL COLLECT(A) -!! INPUT ARGUMENT LIST: -!! A - ARRAY BEING GATHERED -!! -!! OUTPUT ARGUMENT LIST: -!! A - GATHERED ARRAY - ONLY VALID ON TASK 0 -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! MPI_GATHERV -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM RS/6000 SP -!! +!> @brief Subroutine that collect gathers from all MPI tasks. +!> +!> @param[in] A Array being gathered. +!> @param[out] A gathered array - only valid on task 0. +!> +!> Gather "A" from all MPI tasks onto task 0. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE COLLECT (A, B) diff --git a/sorc/ncep_post.fd/COLLECT_LOC.f b/sorc/ncep_post.fd/COLLECT_LOC.f index 589cee1ba..bcd005242 100644 --- a/sorc/ncep_post.fd/COLLECT_LOC.f +++ b/sorc/ncep_post.fd/COLLECT_LOC.f @@ -1,54 +1,140 @@ !> @file -! -!> SUBPROGRAM: COLLECT GATHERS FROM ALL MPI TASKS -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! GATHER "A" FROM ALL MPI TASKS ONTO TASK 0 -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! -!! USAGE: CALL COLLECT(A) -!! INPUT ARGUMENT LIST: -!! A - ARRAY BEING GATHERED -!! -!! OUTPUT ARGUMENT LIST: -!! A - GATHERED ARRAY - ONLY VALID ON TASK 0 -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! MPI_GATHERV -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM RS/6000 SP -!! +!> @brief Subroutine that collect gathers from all MPI tasks. +!> +!> @param[in] A Array being gathered. +!> @param[out] A gathered array - only valid on task 0. +!> +!> Gather "A" from all MPI tasks onto task 0. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----------|---------------------|---------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> 2021-06-01 | George Vandenberghe | 2D Decomposition +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE COLLECT_LOC ( A, B ) use CTLBLK_mod, only: num_procs, jsta, icnt, idsp, mpi_comm_comp, im,& - jsta_2l, jend_2u, jm, me + jsta_2l, jend_2u, jm, me, & + buff,ista_2l,iend_2u,jexa,iexa,jsxa,isxa,ista,iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! include 'mpif.h' - real, dimension(im,jsta_2l:jend_2u), intent(in) :: a + integer ii,jj,isum + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: a real, dimension(im,jm), intent(out) :: b - integer ierr + integer ierr,n + real, allocatable :: rbufs(:) + allocate(buff(im*jm)) + jj=( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1) + allocate( rbufs(( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1)) ) ! if ( num_procs <= 1 ) then b = a else - call mpi_gatherv(a(1,jsta),icnt(me),MPI_REAL, & - & b,icnt,idsp,MPI_REAL,0,MPI_COMM_COMP, ierr ) - - end if + +!GWV reshape the receive subdomain + + isum=1 + do jj=jsxa(me),jexa(me) + do ii=isxa(me),iexa(me) + if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj.lt. 1) & + write(0,901)' BOUNDS2 FAIL in reshape ',isum,ii,jj,im*jm,im,im*jm + rbufs(isum)=a(ii,jj) + isum=isum+1 + end do + end do + +!GWV end reshape + + call mpi_gatherv(rbufs,icnt(me),MPI_REAL, buff,icnt,idsp,MPI_REAL,0,MPI_COMM_WORLD, ierr ) + +!GWV reshape the gathered array + + if(me .eq. 0) then + isum=1 + do n=0,num_procs-1 + do jj=jsxa(n),jexa(n) + do ii=isxa(n),iexa(n) + if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj .lt. 1) & + write(0,901)' BOUNDS FAIL in reshape ',isum,ii,jj,im*jm,im,im*jm + b(ii,jj)=buff(isum) + isum=isum+1 + end do + end do + end do + end if + + endif ! num_procs <= 1 + + 901 format(a30,10i10) + + deallocate(buff) + deallocate(rbufs) end +! +!----------------------------------------------------------------------- +! + SUBROUTINE COLLECT_ALL ( A, B ) + + use CTLBLK_mod, only: num_procs, jsta, icnt, idsp, mpi_comm_comp, im,& + jsta_2l, jend_2u, jm, me, & + buff,ista_2l,iend_2u,jexa,iexa,jsxa,isxa,ista,iend,jend +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + include 'mpif.h' + integer ii,jj,isum + real, dimension(ista:iend,jsta:jend), intent(in) :: a + real, dimension(im,jm), intent(out) :: b + integer ierr,n + real, allocatable :: rbufs(:) + allocate(buff(im*jm)) + jj=( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1) + allocate( rbufs(( jexa(me)-jsxa(me)+1) * (iexa(me)-isxa(me)+1)) ) +! + if ( num_procs <= 1 ) then + b = a + else + +!GWV reshape the receive subdomain + isum=1 + do jj=jsxa(me),jexa(me) + do ii=isxa(me),iexa(me) + if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj.lt. 1) & + write(0,901)' BOUNDS2 FAIL in reshape',isum,ii,jj,im*jm,im,im*jm + rbufs(isum)=a(ii,jj) + isum=isum+1 + end do + end do +!GWV end reshape + + call mpi_allgatherv(rbufs,icnt(me),MPI_REAL,buff,icnt,idsp,MPI_REAL, mpi_comm_comp, ierr ) + call mpi_barrier(mpi_comm_comp,ierr) + +!GWV reshape the gathered array and collect in all procs + isum=1 + do n=0,num_procs-1 + do jj=jsxa(n),jexa(n) + do ii=isxa(n),iexa(n) + if(isum .gt. im*jm .or. ii .gt. im .or. ii .lt. 1 .or. jj .gt. jm .or. jj .lt. 1) & + write(0,901)' BOUNDS FAIL in reshape',isum,ii,jj,im*jm,im,im*jm + b(ii,jj)=buff(isum) + isum=isum+1 + end do + end do + end do + + endif ! num_procs <= 1 + + 901 format(a30,10i10) + + deallocate(buff) + deallocate(rbufs) + + end + diff --git a/sorc/ncep_post.fd/CTLBLK.f b/sorc/ncep_post.fd/CTLBLK.f index df647f1dd..5ca6a0f60 100644 --- a/sorc/ncep_post.fd/CTLBLK.f +++ b/sorc/ncep_post.fd/CTLBLK.f @@ -9,6 +9,7 @@ module CTLBLK_mod ! 2011-02 Jun Wang - ADD variables for grib2 ! 2011-12-14 SARAH LU - ADD AER FILENAME ! 2011-12-23 SARAH LU - ADD NBIN FOR DU, SS, OC, BC, SU +! 2021-09-30 JESSE MENG- 2D DECOMPOSITION !----------------------------------------------------------------------- ! implicit none @@ -54,11 +55,25 @@ module CTLBLK_mod SPL(komax),ALSL(komax),PREC_ACC_DT,PT_TBL,PREC_ACC_DT1,spval ! real :: SPVAL=9.9e10 ! Moorthi ! - integer :: NUM_PROCS,ME,JSTA,JEND,JSTA_M,JEND_M, & - JSTA_M2,JEND_M2,IUP,IDN,ICNT(0:1023),IDSP(0:1023), & - JSTA_2L, JEND_2U,JVEND_2u,NUM_SERVERS, MPI_COMM_INTER, & + integer :: NUM_PROCS,ME,JSTA,JEND,ISTA,IEND, & + JSTA_M,JEND_M, JSTA_M2,JEND_M2, & + ISTA_M,IEND_M,ISTA_M2,IEND_M2, & + IUP,IDN,ICNT(0:1023),IDSP(0:1023), ICNT2(0:1023),IDSP2(0:1023), & + JSTA_2L, JEND_2U,JVEND_2U, & + ISTA_2L, IEND_2U,IVEND_2U, & + NUM_SERVERS, MPI_COMM_INTER, & MPI_COMM_COMP, IM,JM,LM,NSOIL,LP1,LM1,IM_JM, & + ileft,iright, & + ileftb,irightb , & + ibsize,ibsum, & lsm,lsmp1 !comm mpi + integer, allocatable :: icoords(:,:),ibcoords(:,:) + real , allocatable :: rcoords(:,:),rbcoords(:,:) + real, allocatable :: bufs(:),buff(:) + integer , allocatable :: isxa(:),iexa(:),jsxa(:),jexa(:) + integer numx + integer, allocatable :: ibufs(:) + real, allocatable :: rbufs(:) ! real :: ARDSW, ARDLW, ASRFC, TSRFC,TRDLW,TRDSW,TCLOD,THEAT, & TPREC,TMAXMIN,TD3D !comm rad diff --git a/sorc/ncep_post.fd/DEALLOCATE.f b/sorc/ncep_post.fd/DEALLOCATE.f index c6cf34ad9..ac9d5c648 100644 --- a/sorc/ncep_post.fd/DEALLOCATE.f +++ b/sorc/ncep_post.fd/DEALLOCATE.f @@ -1,35 +1,16 @@ !> @file -! -!> SUBPROGRAM: MPI_FIRST SET UP MESSGAE PASSING INFO -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! SETS UP MESSAGE PASSING INFO -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! -!! USAGE: CALL MPI_FIRST -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! PARA_RANGE -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM RS/6000 SP -!! +!> @brief MPI_FIRST set up message passing info. +!> +!> This routine sets up message passing info. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> 2001-10-25 | H Chuang | Modified to process hybrid model output +!> 2002-06-19 | Mike Baldwin | WRF version +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE DE_ALLOCATE ! @@ -206,6 +187,7 @@ SUBROUTINE DE_ALLOCATE deallocate(tsnow) deallocate(qvg) deallocate(qv2m) + deallocate(qvl1) deallocate(rswin) deallocate(swddni) deallocate(swddif) @@ -386,6 +368,7 @@ SUBROUTINE DE_ALLOCATE deallocate(tedir) deallocate(twa) deallocate(fdnsst) + deallocate(pwat) ! GSD deallocate(rainc_bucket) deallocate(rainc_bucket1) @@ -550,7 +533,9 @@ SUBROUTINE DE_ALLOCATE deallocate(dustallcb) deallocate(ssallcb) deallocate(dustpm) + deallocate(dustpm10) deallocate(sspm) + deallocate(maod) endif ! ! HWRF RRTMG output diff --git a/sorc/ncep_post.fd/DEWPOINT.f b/sorc/ncep_post.fd/DEWPOINT.f index e310dd778..1b962871d 100644 --- a/sorc/ncep_post.fd/DEWPOINT.f +++ b/sorc/ncep_post.fd/DEWPOINT.f @@ -1,53 +1,49 @@ !> @file -! -!> SUBPROGRAM: DEWPOINT COMPUTES DEWPOINTS FROM VAPOR PRESSURE -!! PRGMMR: J TUCCILLO ORG: W/NP2 DATE: 90-05-19 -!! -!! ABSTRACT: COMPUTES THE DEWPOINTS FOR THE N VALUES -!! OF VAPOR PRESSURE IN ARRAY VP. -!! THE FORMULA: -!! -!! VP = 0.611 * (X**A) * EXP( (A+B)*(1-X) ) -!! -!! IS USED TO GET DEWPOINT TEMPERATURE T, WHERE -!! -!! X = T3/T, T3=TRIPLE PT TEMPERATURE, -!! VP=VAPOR PRESSURE IN CBS, 0.611=VP AT T3, -!! A=(SPEC. HT. OF WATER-CSUBP OF VAPOR)/GAS CONST OF VAPOR -!! AND -!! B=LATENT HEAT AT T3/(GAS CONST OF VAPOR TIMES T3). -!! -!! ON THE FIRST CALL, A TABLE TDP IS CONSTRUCTED GIVING -!! DEWPOINT AS A FUNCTION OF VAPOR PRESSURE. -!! -!! VALUES OF VP LESS THAN THE FIRST TABLE ENTRY -!! (RVP1 IN THE CODE) WILL BE GIVEN DEWPOINTS FOR -!! THAT BEGINNING VALUE. SIMILARLY , VP VALUES THAT -!! EXCEED THE MAXIMUM TABLE VALUE (RVP2 IN THE CODE) -!! WILL BE ASSIGNED DEWPOINTS FOR THAT MAXIMUM VALUE. -!! -!! THE VALUES 0.02 AND 8.0 FOR RVP1 AND RVP2 YIELD -!! DEWPOINTS OF 233.6K AND 314.7K,RESPECTIVELY. -!! -!! PROGRAM HISTORY LOG: -!! - 90-05-19 J TUCCILLO -!! - 93-05-12 R TREADON - EXPANDED TABLE SIZE AND RESET -!! RANGE OF PRESSURES COVERED BY -!! TABLE. -!! - 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D -!! - 00-01-04 JIM TUCCILLO - MPI VERSION -!! - 21-07-26 W Meng - Restrict computation from undefined grids -!! -!! USAGE: CALL DEWPOINT( VP, TD) -!! INPUT ARGUMENT LIST: -!! VP - ARRAY OF N VAPOR PRESSURES(CENTIBARS) -!! -!! OUTPUT ARGUMENT LIST: -!! TD - DEWPOINT IN DEGREES ABSOLUTE -!! +!> @brief Subroutine that computes dewpoints from vapor pressure. +!> +!> This routine is to computes the dewpoints for the N values +!> of vapor pressure in array VP. +!> The forumla: +!> +!> VP = 0.611 * (X**A) * EXP( (A+B)*(1-X) ) +!> +!> is used to get dewpoint temperature T, where +!> +!> X = T3/T, T3=Triple PT temperature, +!> VP=Vapor pressure in CBS, 0.611=VP at T3, +!> A=(Spec. HT. of WATER-CSUBP of vapor)/gas const of vapor +!> and +!> B=Latent heat at T3/(gas const of vapor times T3). +!> +!> on the first call, a table TDP is constructed giving +!> dewpoint as a function of vapor pressure. +!> +!> Values of VP less than the first table entry +!> (RVP1 in the code) will be given dewpoints for +!> that beginning valus. Similarly, VP vaules that +!> exceed the maximum table value (RVP2 in the code) +!> will be assigned dewpoints for that maximum value. +!> +!> The values 0.02 and 8.0 for RVP1 and RVP2 yield +!> dewpoints of 233.6K and 314.7K,respectively. +!> +!> @param[in] VP Array of N vapor pressures(centibars). +!> @param[out] TD Dewpoint in degrees absolute. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1990-05-19 | Jim Tuccillo | Initial +!> 1993-05-12 | R Treadon | Expanded table size and reset range of pressures covered by table. +!> 1998-06-12 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2021-07-26 | W Meng | Restrict computation from undefined grids +!> 2021-10-31 | J Meng | 2D Decomposition +!> +!> @author Jim Tuccillo W/NP2 @date 1990-05-19 SUBROUTINE DEWPOINT( VP, TD) - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: jsta, jend, im, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -55,8 +51,8 @@ SUBROUTINE DEWPOINT( VP, TD) integer,PARAMETER :: NT=2000 !...TRANSLATED BY FPP 3.00Z36 11/09/90 14:48:53 !...SWITCHES: OPTON=I47,OPTOFF=VAE0 - real,intent(out) :: TD(IM,jsta:jend) - real,intent(in) :: VP(IM,jsta:jend) + real,intent(out) :: TD(ista:iend,jsta:jend) + real,intent(in) :: VP(ista:iend,jsta:jend) real TDP(NT) !jw integer NN,I,J,JNT @@ -132,7 +128,7 @@ SUBROUTINE DEWPOINT( VP, TD) ! !$omp parallel do private(i,j,w1,w2,jnt) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(VP(I,J) @file -! -!> SUBPROGRAM: EXCH EXCHANGE ONE HALO ROW -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! EXCHANGE ONE HALO ROW -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL -!! -!! USAGE: CALL EXCH(A) -!! INPUT ARGUMENT LIST: -!! A - ARRAY TO HAVE HALOS EXCHANGED -!! -!! OUTPUT ARGUMENT LIST: -!! A - ARRAY WITH HALOS EXCHANGED -!! -!! OUTPUT FILES: -!! STDOUT - RUN TIME STANDARD OUT. -!! -!! SUBPROGRAMS CALLED: -!! MPI_SENDRECV -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK.comm -!! -!@PROCESS NOCHECK -! -!--- The 1st line is an inlined compiler directive that turns off -qcheck -! during compilation, even if it's specified as a compiler option in the -! makefile (Tuccillo, personal communication; Ferrier, Feb '02). -! +!> @brief Subroutines that exchange one halo row. +!> +!> These routines are to exchange one halo row. +!> +!> @param[in] A Array to have halos exchanged. +!> @param[out] A Array with halos exchanged. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----------|---------------------|---------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> 2021-06-01 | George Vandenberghe | 2D decomposition +!> +!> @note The 1st line is an inlined compiler directive that turns off -qcheck +!> during compilation, even if it's specified as a compiler option in the +!> makefile (Tuccillo, personal communication; Ferrier, Feb '02). +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 SUBROUTINE EXCH(A) use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,& - jsta_2l, jend_2u + icoords,ibcoords,bufs,ibufs,me,numx, & + jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,modelname !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! include 'mpif.h' ! - real,intent(inout) :: a ( im,jsta_2l:jend_2u ) + real,intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u ) + real, allocatable :: coll(:), colr(:) + integer, allocatable :: icoll(:), icolr(:) integer status(MPI_STATUS_SIZE) - integer ierr, jstam1, jendp1 + integer ierr, jstam1, jendp1,j + integer size,ubound,lbound + integer msglenl, msglenr + integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc + integer iwest,ieast + integer ifirst + + logical, parameter :: checkcoords = .false. + + data ifirst/0/ + allocate(coll(jm)) + allocate(colr(jm)) + allocate(icolr(jm)) + allocate(icoll(jm)) + ibl=max(ista-1,1) + ibu=min(im,iend+1) + jbu=min(jm,jend+1) + jbl=max(jsta-1,1) ! + ! write(0,*) 'mype=',me,'num_procs=',num_procs,'im=',im,'jsta_2l=', & ! jsta_2l,'jend_2u=',jend_2u,'jend=',jend,'iup=',iup,'jsta=', & ! jsta,'idn=',idn if ( num_procs <= 1 ) return ! +! for global model apply cyclic boundary condition + + IF(MODELNAME == 'GFS') then + if(ifirst .le. 0 .and. me .eq. 0) print *,' CYCLIC BC APPLIED' + if(ileft .eq. MPI_PROC_NULL) iwest=1 ! get eastern bc from western boundary of full domain + if(iright .eq. MPI_PROC_NULL) ieast=1 ! get western bc from eastern boundary of full domain + if(ileft .eq. MPI_PROC_NULL) ileft=me+(numx-1) + if(iright .eq. MPI_PROC_NULL) iright=(me-numx) +1 + endif + jstam1 = max(jsta_2l,jsta-1) ! Moorthi - call mpi_sendrecv(a(1,jend),im,MPI_REAL,iup,1, & - & a(1,jstam1),im,MPI_REAL,idn,1, & + +! send last row to iup's first row+ and receive first row- from idn's last row + + call mpi_sendrecv(a(ista,jend),iend-ista+1,MPI_REAL,iup,1, & + & a(ista,jstam1),iend-ista+1,MPI_REAL,idn,1, & & MPI_COMM_COMP,status,ierr) -! print *,'mype=',me,'in EXCH, after first mpi_sendrecv' + if ( ierr /= 0 ) then - print *, ' problem with first sendrecv in exch, ierr = ',ierr - stop + print *, ' problem with first sendrecv in exch, ierr = ',ierr + stop 6661 + endif + + if (checkcoords) then + if(ifirst .le. 0) then !IFIRST ONLY + call mpi_sendrecv(ibcoords(ista,jend),iend-ista+1,MPI_INTEGER,iup,1, & + & ibcoords(ista,jstam1),iend-ista+1,MPI_INTEGER,idn,1, & + & MPI_COMM_COMP,status,ierr) + if ( ierr /= 0 ) then + print *, ' problem with second sendrecv in exch, ierr = ',ierr + stop 7661 + endif + do i=ista,iend + ii=ibcoords(i,jstam1)/10000 + jj=ibcoords(i,jstam1)-(ii*10000) + if(ii .ne. i .or. jj .ne. jstam1 ) print *,' GWVX JEXCH CHECK FAIL ',ii,jj,ibcoords(i,jstam1),i + end do + endif !IFIRST + endif !checkcoords + +! build the I columns to send and receive + + msglenl=jend-jsta+1 + msglenr=jend-jsta+1 + if(iright .lt. 0) msglenr=1 + if(ileft .lt. 0) msglenl=1 + + do j=jsta,jend + coll(j)=a(ista,j) + end do + + call mpi_barrier(mpi_comm_comp,ierr) + +! send first col to ileft last col+ and receive last col+ from ileft first col + + call mpi_sendrecv(coll(jsta),msglenl ,MPI_REAL,ileft,1, & + & colr(jsta),msglenr ,MPI_REAL,iright,1, & + & MPI_COMM_COMP,status,ierr) + + if ( ierr /= 0 ) then + print *, ' problem with third sendrecv in exch, ierr = ',ierr + stop 6662 + endif + + if(ifirst .le. 0) then ! IFIRST ONLY + call mpi_sendrecv(icoll(jsta),msglenl ,MPI_INTEGER,ileft,1, & + & icolr(jsta),msglenr ,MPI_INTEGER,iright,1, & + & MPI_COMM_COMP,status,ierr) + if ( ierr /= 0 ) then + print *, ' problem with fourth sendrecv in exch, ierr = ',ierr + stop 7662 + endif + endif !IFIRST + + if(iright .ge. 0) then + do j=jsta,jend + a(iend+1,j)=colr(j) + if(checkcoords) then + if(ifirst .le. 0) then !IFIRST ONLY + ibcoords(iend+1,j)=icolr(j) + ii=ibcoords(iend+1,j)/10000 + jj=ibcoords( iend+1,j)-(ii*10000) + if( j .ne. jj .or. ii .ne. iend+1 .and. ii .ne. im .and. ii .ne. 1) & + write(0,921) j,iend+1,ii,jj,ibcoords(iend+1,j),'IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord ' + endif !IFIRST + endif !checkcoords + end do + endif ! for iright + + 921 format(5i10,a50) + +! print *,'mype=',me,'in EXCH, after first mpi_sendrecv' + + if ( ierr /= 0 ) then + print *, ' problem with fifth sendrecv in exch, ierr = ',ierr + stop 6663 end if jendp1 = min(jend+1,jend_2u) ! Moorthi - call mpi_sendrecv(a(1,jsta),im,MPI_REAL,idn,1, & - & a(1,jendp1),im,MPI_REAL,iup,1, & + +!GWV. change from full im row exchange to iend-ista+1 subrow exchange, + + do j=jsta,jend + colr(j)=a(iend,j) + end do + +! send first row to idown's last row+ and receive last row+ from iup's first row + + call mpi_sendrecv(a(ista,jsta),iend-ista+1,MPI_REAL,idn,1, & + & a(ista,jendp1),iend-ista+1,MPI_REAL,iup,1, & + & MPI_COMM_COMP,status,ierr) + if ( ierr /= 0 ) then + print *, ' problem with sixth sendrecv in exch, ierr = ',ierr + stop 6664 + endif + + if (checkcoords) then + if (ifirst .le. 0) then + call mpi_sendrecv(ibcoords(ista,jsta),iend-ista+1,MPI_INTEGER,idn,1, & + & ibcoords(ista,jendp1),iend-ista+1,MPI_INTEGER,iup,1, & & MPI_COMM_COMP,status,ierr) -! print *,'mype=',me,'in EXCH, after second mpi_sendrecv' + if ( ierr /= 0 ) then + print *, ' problem with seventh sendrecv in exch, ierr = ',ierr + stop 7664 + endif + endif ! IFIRST + endif ! checkcoords + +! send last col to iright first col- and receive first col- from ileft last col + + call mpi_sendrecv(colr(jsta),msglenr ,MPI_REAL,iright,1 , & + & coll(jsta),msglenl ,MPI_REAL,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + + if ( ierr /= 0 ) then + print *, ' problem with eighth sendrecv in exch, ierr = ',ierr + stop 6665 + endif + + if (ifirst .le. 0) then + call mpi_sendrecv(icolr(jsta),msglenr ,MPI_integer,iright,1 , & + & icoll(jsta),msglenl ,MPI_integer,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + if ( ierr /= 0 ) then + print *, ' problem with ninth sendrecv in exch, ierr = ',ierr + stop 7665 + endif + endif !IFIRST + + if(ileft .ge. 0) then + do j=jsta,jend + a(ista-1,j)=coll(j) + if(checkcoords) then + if(ifirst .le. 0) then + ibcoords(ista-1,j)=icoll(j) + ii=ibcoords(ista-1,j)/10000 + jj=ibcoords( ista-1,j)-(ii*10000) + if( j .ne. jj .or. ii .ne. ista-1 .and. ii .ne. im .and. ii .ne. 1) & + write(0,921) j,ista-1,ii,jj,ibcoords(ista-1,j),'EXCH COORD FAIL j,ista-1,ii,jj,ibcoord ' + endif !IFIRST + endif !checkcoords + end do + endif + +! interior check + + if(checkcoords) then + if(ifirst .le. 0) then + do j=jsta,jend + do i=ista,iend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .or. jj .ne. j) write(0,151) 'INFAILED IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + end do + endif !IFIRST + endif !checkcoords + +!! corner points. After the exchanges above, corner points are replicated in +! neighbour halos so we can get them from the neighbors rather than +! calculating more corner neighbor numbers +! A(ista-1,jsta-1) is in the ileft a(iend,jsta-1) location +! A(ista-1,jend+1) is in the ileft a(iend,jend+1) location +! A(iend+1,jsta-1) is in the iright a(ista,jsta-1) location +! A(iend+1,jend+1) is in the iright a(ista,jend+1) location +!GWVx ibl=max(ista-1,1) +!GWVx ibu=min(im,iend+1) + + ibl=max(ista-1,1) + ibu=min(im,iend+1) + if(modelname == 'GFS') then + ibl=max(ista-1,0) + ibu=min(im+1,iend+1) + endif + + jbu=min(jm,jend+1) + jbl=max(jsta-1,1) + + call mpi_sendrecv(a(iend,jbl ),1, MPI_REAL,iright,1 , & + & a(ibl ,jbl ),1, MPI_REAL,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + if ( ierr /= 0 ) then + print *, ' problem with tenth sendrecv in exch, ierr = ',ierr + stop 6771 + endif + + call mpi_sendrecv(a(iend,jbu ),1, MPI_REAL,iright,1 , & + & a(ibl ,jbu ),1, MPI_REAL,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + + if ( ierr /= 0 ) then + print *, ' problem with eleventh sendrecv in exch, ierr = ',ierr + stop 6772 + endif + + call mpi_sendrecv(a(ista,jbl ),1, MPI_REAL,ileft ,1, & + & a(ibu ,jbl ),1, MPI_REAL,iright,1, & + & MPI_COMM_COMP,status,ierr) + + if ( ierr /= 0 ) then + print *, ' problem with twelft sendrecv in exch, ierr = ',ierr + stop 6773 + endif + + call mpi_sendrecv(a(ista,jbu ),1, MPI_REAL,ileft ,1 , & + & a(ibu ,jbu ),1, MPI_REAL,iright,1, & + & MPI_COMM_COMP,status,ierr) + + if ( ierr /= 0 ) then + print *, ' problem with thirteenth sendrecv in exch, ierr = ',ierr + stop 6774 + endif + + 139 format(a20,5(i10,i6,i6,'<>')) + + if(checkcoords) then + if(ifirst .le. 0) then + call mpi_sendrecv(ibcoords(iend,jbl ),1 ,MPI_INTEGER,iright,1 , & + & ibcoords(ibl ,jbl ),1 ,MPI_INTEGER,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + + call mpi_sendrecv(ibcoords(iend,jbu ),1 ,MPI_INTEGER,iright,1, & + & ibcoords(ibl ,jbu ),1 ,MPI_INTEGER,ileft ,1, & + & MPI_COMM_COMP,status,ierr) + call mpi_sendrecv(ibcoords(ista,jbl ),1 ,MPI_INTEGER,ileft ,1, & + & ibcoords(ibu ,jbl ),1 ,MPI_INTEGER,iright,1, & + & MPI_COMM_COMP,status,ierr) + call mpi_sendrecv(ibcoords(ista,jbu ),1 ,MPI_INTEGER,ileft ,1 , & + & ibcoords(ibu ,jbu ),1 ,MPI_INTEGER,iright,1, & + MPI_COMM_COMP,status,ierr) + +! corner check for coordnates + + icc=ibl + jcc=jbl + ii=ibcoords(icc,jcc)/10000 + jj=ibcoords(icc,jcc)-(ii*10000) + + if(ii .ne. icc .and. icc .ne. 0) write(0,151) ' CORNER FAILI ilb ll ',icc,jcc,ibcoords(icc,jcc),ii,jj + if( jj .ne. jcc) write(0,151) ' CORNER FAILJ ilb ll ',icc,jcc,ibcoords(icc,jcc),ii,jj + + icc=ibu + jcc=jbl + ii=ibcoords(icc,jcc)/10000 + jj=ibcoords(icc,jcc)-(ii*10000) + if(ii .ne. icc .and. icc .ne. im+1 ) write(0,151) ' CORNER FAILI ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj + if( jj .ne. jcc ) write(0,151) ' CORNER FAILJ ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj + + icc=ibu + jcc=jbu + ii=ibcoords(icc,jcc)/10000 + jj=ibcoords(icc,jcc)-(ii*10000) + if(ii .ne. icc .and. icc .ne. im+1) write(0,151) ' CORNER FAILI ilb uu ',icc,jcc,ibcoords(icc,jcc),ii,jj + if( jj .ne. jcc ) write(0,151) ' CORNER FAILJ ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj + + icc=ibl + jcc=jbu + ii=ibcoords(icc,jcc)/10000. + jj=ibcoords(icc,jcc)-(ii*10000) + if(ii .ne. icc .and. icc .ne. 0 ) write(0,151) ' CORNER FAILI ilb lu ',icc,jcc,ibcoords(icc,jcc),ii,jj + if( jj .ne. jcc ) write(0,151) ' CORNER FAILJ ilb ul ',icc,jcc,ibcoords(icc,jcc),ii,jj + +! if(ileft .ge. 0) then +!119 format(' GWX LEFT EXCHANGE ileft,me,ibcoords(ista-1,jend+1),ibcoords(ista-1,jend-1),ista-1,jend-1,jend+1', & +! 10i10) +! endif + +! if(iright .ge. 0) then +!! write(0,129) iright,me,ibcoords(ista+1,jend+1),ibcoords(ista+1,jend-1),ista-1,jend-1,jend+1 !GWVX +!129 format(' GWX RIGHT EXCHANGE iright,me,ibcoords(ista+1,jend+1),ibcoords(ista-1,jend+1),ista-1,jend-1,jend+1', & +! 10i10) +! endif + +! interior check + + do j=jsta,jend + do i=ista,iend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .or. jj .ne. j) write(0,151) 'GWVX FAILED IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + end do + + 151 format(a70,10i10) + +! bounds check +! first check top and bottom halo rows + + j=jbu + do i=ista,iend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .or. jj .ne. j) write(0,151) 'GWVX FAILEDI JBU IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + + j=jbl + do i=ista,iend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .or. jj .ne. j) write(0,151) 'GWVX FAILEDI JBL IJ ',i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + +! second and last, check left and right halo columns + + i=ibl + do j=jsta,jend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .and. ii .ne. im .or. jj .ne. j) write(0,151) 'GWVX FAILED IBL IJ ',ii,i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + + i=ibu + do j=jsta,jend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .and. ii .ne. 1 .or. jj .ne. j) write(0,151) 'GWVX FAILED IBU ii i j ibcoords ibl,jbl,ibu,jbu',ii,i,j,ibcoords(i,j),ibl,jbl,ibu,jbu + end do + + if(me .eq. 0) write(0,*) ' IFIRST CHECK' + + endif ! IFIRST + endif !checkcoords + +! end halo checks if ( ierr /= 0 ) then print *, ' problem with second sendrecv in exch, ierr = ',ierr stop end if -! + call mpi_barrier(mpi_comm_comp,ierr) + ifirst=ifirst+1 end !!@PROCESS NOCHECK -! -!--- The 1st line is an inlined compiler directive that turns off -qcheck -! during compilation, even if it's specified as a compiler option in the -! makefile (Tuccillo, personal communication; Ferrier, Feb '02). -! +!> +!> @note The 1st line is an inlined compiler directive that turns off -qcheck +!> during compilation, even if it's specified as a compiler option in the +!> makefile (Tuccillo, personal communication; Ferrier, Feb '02). +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 subroutine exch_f(a) use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, & diff --git a/sorc/ncep_post.fd/EXCH2.f b/sorc/ncep_post.fd/EXCH2.f deleted file mode 100644 index d5bce4036..000000000 --- a/sorc/ncep_post.fd/EXCH2.f +++ /dev/null @@ -1,72 +0,0 @@ -!!@PROCESS NOCHECK -! -!--- The 1st line is an inlined compiler directive that turns off -qcheck -! during compilation, even if it's specified as a compiler option in the -! makefile (Tuccillo, personal communication; Ferrier, Feb '02). -! - SUBROUTINE EXCH2(A) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: EXCH EXCHANGE ONE HALO ROW -! PRGRMMR: TUCCILLO ORG: IBM -! -! ABSTRACT: -! EXCHANGE ONE HALO ROW -! . -! -! PROGRAM HISTORY LOG: -! 00-01-06 TUCCILLO - ORIGINAL -! -! USAGE: CALL EXCH(A) -! INPUT ARGUMENT LIST: -! A - ARRAY TO HAVE HALOS EXCHANGED -! -! OUTPUT ARGUMENT LIST: -! A - ARRAY WITH HALOS EXCHANGED -! -! OUTPUT FILES: -! STDOUT - RUN TIME STANDARD OUT. -! -! SUBPROGRAMS CALLED: -! MPI_SENDRECV -! UTILITIES: -! NONE -! LIBRARY: -! COMMON - CTLBLK.comm -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : IBM RS/6000 SP -!$$$ - use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,& - jsta_2l, jend_2u -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - include 'mpif.h' -! - real,intent(inout) :: a ( im,jsta_2l:jend_2u ) - integer status(MPI_STATUS_SIZE) - integer ierr, jstam2, jendp1 -! - if ( num_procs <= 1 ) return -! - jstam2 = max(jsta_2l,jsta-2) - call mpi_sendrecv(a(1,jend-1),2*im,MPI_REAL,iup,1, & - & a(1,jstam2),2*im,MPI_REAL,idn,1, & - & MPI_COMM_COMP,status,ierr) - if ( ierr /= 0 ) then - print *, ' problem with first sendrecv in exch2, ierr = ',ierr - stop - end if - jendp1 = min(jend+1,jend_2u) - call mpi_sendrecv(a(1,jsta),2*im,MPI_REAL,idn,1, & - & a(1,jendp1),2*im,MPI_REAL,iup,1, & - & MPI_COMM_COMP,status,ierr) - if ( ierr /= 0 ) then - print *, ' problem with second sendrecv in exch2, ierr = ',ierr - stop - end if -! - end - diff --git a/sorc/ncep_post.fd/FDLVL.f b/sorc/ncep_post.fd/FDLVL.f index 81441ac3b..fbe110473 100644 --- a/sorc/ncep_post.fd/FDLVL.f +++ b/sorc/ncep_post.fd/FDLVL.f @@ -1,71 +1,46 @@ !> @file -! -!> SUBPROGRAM: FDLVL COMPUTES FD LEVEL T, Q, U, V -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES TEMPERATURE, SPEC. HUM, U WIND COMPONENT, -!! AND V WIND COMPONENT ON THE NFD=6 FD LEVELS. THE -!! HEIGHT OF THESE LEVELS (IN METERS) IS GIVEN IN THE -!! DATA STATEMENT BELOW. THE ALGORITHM PROCEEDS AS -!! FOLLOWS. (AGL IN PARENTHESES) -!! -!! AT EACH MASS POINT MOVE UP VERTICALLY FROM THE LM-TH (LOWEST -!! ATMOSPHERIC) ETA LAYER. FIND THE ETA LAYERS WHOSE -!! HEIGHT (ABOVE GROUND) BOUNDS THE TARGET FD LEVEL HEIGHT. -!! VERTICALLY INTERPOLATE TO GET TEMPERATURE AT THIS FD -!! LEVEL. AVERAGE THE FOUR SURROUNDING WINDS -!! TO GET A MASS POINT WIND. VERTICALLY INTERPOLATE THESE -!! MASS POINT WINDS TO THE TARGET FD LEVEL. CONTINUE THIS -!! PROCESS UNTIL ALL NFD=6 FD LEVELS HAVE BEEN PROCESSED. -!! MOVE ON TO THE NEXT MASS POINT. -!! -!! AVERAGING THE FOUR ABOVE GROUND WINDS TO THE MASS POINT -!! WAS FOUND TO SMOOTH THE FIELD AND REDUCE THE OCCURRENCE -!! OF POINT PEAK WINDS FAR IN EXCESS OF THE WINDS AT -!! ADJACENT POINTS. MASS POINT VALUES ARE RETURNED. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-11-23 RUSS TREADON - CORRECTED ROUTINE TO COMPUTE -!! FD LEVELS WITH REPECT TO MEAN SEA LEVEL. -!! 94-01-04 MICHAEL BALDWIN - INCLUDE OPTIONS FOR COMPUTING -!! EITHER AGL OR MSL -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 11-12-14 SARAH LU - ADD GOCART AEROSOL AERFD -!! -!! USAGE: CALL FDLVL(ITYPE,TFD,QFD,UFD,VFD) -!! INPUT ARGUMENT LIST: -!! ITYPE - FLAG THAT DETERMINES WHETHER MSL (1) OR AGL (2) -!! LEVELS ARE USED. -!! -!! OUTPUT ARGUMENT LIST: -!! TFD - TEMPERATURE (K) ON FD LEVELS. -!! QFD - SPEC HUM ON FD LEVELS. -!! UFD - U WIND (M/S) ON FD LEVELS. -!! VFD - V WIND (M/S) ON FD LEVELS. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - -!! LOOPS -!! MASKS -!! OPTIONS -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! -! SUBROUTINE FDLVL(NFD,ITYPE,HTFD,TFD,QFD,UFD,VFD,PFD) -! SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD) +!> @brief Subroutine that computes T, Q, U, V on the flight levels (FD). +!> +!> This routine computes temperature, spec. hum, u wind component, +!> and v wind component on the NFD=6 FD levels. The +!> height of these levels (in meters) is given in the +!> data statement below. The alogrithm proceeds as +!> follows. (AGL-Above ground level in parentheses) +!> +!> At each mass point move up vertically from the LM-TH (lowest +!> atmospheric) ETA layer. Find the ETA layers whose +!> height (above ground) bounds the target FD level height. +!> Vertically interpolate to get temperature at this FD +!> level. Average the four surrounding winds +!> to get a mass point wind. Vertically interpolate these +!> mass point winds to the target FD level. Continue this +!> process until all NFD=6 FD levels have been processed. +!> Move on to the next mass point. +!> +!> Averaging the four above ground winds to the mass point +!> was found to smooth the field and reduce the occurrence +!> of point peak winds far in excess of the winds at +!> adjacent points. Mass point values are returned. +!> +!> @param[in] ITYPE Flag that determines whether MSL (1) or AGL (2) Levels are used. +!> @param[out] TFD Temperature (K) on FD levels. +!> @param[out] QFD Spec hum on FD levels. +!> @param[out] UFD U wind (m/s) on FD levels. +!> @param[out] VFD V wind (m/s) on FD levels. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-11-23 | Russ Treadon | Corrected routine to compute FD levels with respect to mean sea level +!> 1994-01-04 | Mike Baldwin | Include options for computing either AGL or MSL +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2011-12-14 | Sarah Lu | Add GOCART aerosol AERFD +!> 2021-10-15 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) ! @@ -77,7 +52,7 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) use params_mod, only: GI, G use ctlblk_mod, only: JSTA, JEND, SPVAL, JSTA_2L, JEND_2U, LM, JSTA_M, & JEND_M, HTFD, NFD, IM, JM, NBIN_DU, gocart_on, & - MODELNAME + MODELNAME, ISTA, IEND, ISTA_2L, IEND_2U, ISTA_M, IEND_M use gridspec_mod, only: GRIDTYPE !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -89,8 +64,8 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) ! integer,intent(in) :: ITYPE(NFD) !jw real,intent(in) :: HTFD(NFD) - real,dimension(IM,JSTA:JEND,NFD),intent(out) :: TFD,QFD,UFD,VFD,PFD,ICINGFD - real,dimension(IM,JSTA:JEND,NFD,NBIN_DU),intent(out) :: AERFD + real,dimension(ISTA:IEND,JSTA:JEND,NFD),intent(out) :: TFD,QFD,UFD,VFD,PFD,ICINGFD + real,dimension(ISTA:IEND,JSTA:JEND,NFD,NBIN_DU),intent(out) :: AERFD ! INTEGER LVL(NFD),LHL(NFD) INTEGER IVE(JM),IVW(JM) @@ -113,7 +88,7 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) !$omp parallel do DO IFD = 1,NFD DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TFD(I,J,IFD) = SPVAL QFD(I,J,IFD) = SPVAL UFD(I,J,IFD) = SPVAL @@ -127,7 +102,7 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) DO N = 1, NBIN_DU DO IFD = 1,NFD DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND AERFD(I,J,IFD,N) = SPVAL ENDDO ENDDO @@ -145,17 +120,17 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) END IF IF(gridtype /= 'A')THEN - CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L=1,LM - CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) END DO - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -456,7 +431,7 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) IF(MODELNAME=='RAPR' .OR. MODELNAME=='NCAR' .OR. MODELNAME=='NMM') THEN ! DO 420 IFD = 1,NFD DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD) < 1.0e-8) QFD(I,J,IFD)=0.0 ENDDO ENDDO @@ -468,74 +443,48 @@ SUBROUTINE FDLVL(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD) RETURN END +!> Computes FD level for u,v. +!> +!> This routine computes u/v wind component on NFD FD levels. +!> The height of these levels (in meters) is passed as an +!> input parameter. The alogrithm proceeds as +!> follows. (AGL-Above ground level in parentheses) +!> +!> At each mass point move up vertically from the LM-TH (lowest +!> atmospheric) ETA layer. Find the ETA layers whose +!> height (above ground) bounds the target FD level height. +!> Vertically interpolate to get temperature at this FD +!> level. Average the four surrounding winds +!> to get a mass point wind. Vertically interpolate these +!> mass point winds to the target FD level. Continue this +!> process until all NFD FD levels have been processed. +!> Move on to the next mass point. +!> +!> Averaging the four above ground winds to the mass point +!> was found to smooth the field and reduce the occurrence +!> of point peak winds far in excess of the winds at +!> adjacent points. Mass point values are returned. +!> +!> @param[in] ITYPE Flag that determines whether MSL (1) or AGL (2) Levels are used. +!> @param[in] NFD Number of FD levels. +!> @param[in] HTFD FD levels. +!> @param[out] UFD U wind (m/s) on FD levels. +!> @param[out] VFD V wind (m/s) on FD levels. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-11-23 | Russ Treadon | Corrected routine to compute FD levels with respect to mean sea level +!> 1994-01-04 | Mike Baldwin | Include options for computing either AGL or MSL +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2011-12-14 | Sarah Lu | Add GOCART aerosol AERFD +!> 2019-09-25 | Y Mao | Seperate U/V from mass +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: FDLVL_UV COMPUTES FD LEVEL U, V -! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES U/V WIND COMPONENT ON NFD FD LEVELS. -! THE HEIGHT OF THESE LEVELS (IN METERS) IS PASSED AS AN -! INPUT PARAMETER. THE ALGORITHM PROCEEDS AS -! FOLLOWS. (AGL IN PARENTHESES) -! -! AT EACH MASS POINT MOVE UP VERTICALLY FROM THE LM-TH (LOWEST -! ATMOSPHERIC) ETA LAYER. FIND THE ETA LAYERS WHOSE -! HEIGHT (ABOVE GROUND) BOUNDS THE TARGET FD LEVEL HEIGHT. -! VERTICALLY INTERPOLATE TO GET TEMPERATURE AT THIS FD -! LEVEL. AVERAGE THE FOUR SURROUNDING WINDS -! TO GET A MASS POINT WIND. VERTICALLY INTERPOLATE THESE -! MASS POINT WINDS TO THE TARGET FD LEVEL. CONTINUE THIS -! PROCESS UNTIL ALL NFD FD LEVELS HAVE BEEN PROCESSED. -! MOVE ON TO THE NEXT MASS POINT. -! -! AVERAGING THE FOUR ABOVE GROUND WINDS TO THE MASS POINT -! WAS FOUND TO SMOOTH THE FIELD AND REDUCE THE OCCURRENCE -! OF POINT PEAK WINDS FAR IN EXCESS OF THE WINDS AT -! ADJACENT POINTS. MASS POINT VALUES ARE RETURNED. -! . -! -! PROGRAM HISTORY LOG: -! 92-12-22 RUSS TREADON -! 93-11-23 RUSS TREADON - CORRECTED ROUTINE TO COMPUTE -! FD LEVELS WITH REPECT TO MEAN SEA LEVEL. -! 94-01-04 MICHAEL BALDWIN - INCLUDE OPTIONS FOR COMPUTING -! EITHER AGL OR MSL -! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 11-12-14 SARAH LU - ADD GOCART AEROSOL AERFD -! 19-25-09 Y Mao - Seperate U/V from mass -! -! USAGE: CALL FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) -! INPUT ARGUMENT LIST: -! ITYPE - FLAG THAT DETERMINES WHETHER MSL (1) OR AGL (2) -! LEVELS ARE USED. -! NFD - NUMBER OF FD LEVELS -! HTFD - FD LEVELS -! -! OUTPUT ARGUMENT LIST: -! UFD - U WIND (M/S) ON FD LEVELS. -! VFD - V WIND (M/S) ON FD LEVELS. -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! -! LIBRARY: -! COMMON - -! LOOPS -! MASKS -! OPTIONS -! INDX -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : CRAY C-90 -!$$$ ! ! use vrbls3d, only: ZMID, PMID, UH, VH @@ -543,7 +492,8 @@ SUBROUTINE FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) use masks, only: LMH use params_mod, only: GI, G use ctlblk_mod, only: JSTA, JEND, SPVAL, JSTA_2L, JEND_2U, LM, JSTA_M, & - JEND_M, IM, JM, MODELNAME + JEND_M, IM, JM, MODELNAME, & + ISTA, IEND, ISTA_2L, IEND_2U, ISTA_M, IEND_M use gridspec_mod, only: GRIDTYPE !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -553,7 +503,7 @@ SUBROUTINE FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) integer,intent(in) :: ITYPE(NFD) integer,intent(in) :: NFD ! coming from calling subroutine real,intent(in) :: HTFD(NFD) - real,dimension(IM,JSTA_2L:JEND_2U,NFD),intent(out) :: UFD,VFD + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFD),intent(out) :: UFD,VFD ! INTEGER LVL(NFD) INTEGER IVE(JM),IVW(JM) @@ -571,7 +521,7 @@ SUBROUTINE FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) !$omp parallel do DO IFD = 1,NFD DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UFD(I,J,IFD) = SPVAL VFD(I,J,IFD) = SPVAL ENDDO @@ -588,17 +538,17 @@ SUBROUTINE FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) END IF IF(gridtype /= 'A')THEN - CALL EXCH(FIS(1:IM,JSTA_2L:JEND_2U)) + CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO L=1,LM - CALL EXCH(ZMID(1:IM,JSTA_2L:JEND_2U,L)) + CALL EXCH(ZMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) END DO - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF @@ -795,112 +745,83 @@ SUBROUTINE FDLVL_UV(ITYPE,NFD,HTFD,UFD,VFD) RETURN END +!> Computes FD level for mass variables. +!> +!> This routine computes mass variables (temperature, spec. hum...) +!> on NFD FD levels. The height of these levels (in meters) is +!> passed as an input parameter. The alogrithm proceeds as +!> follows. (AGL-Above ground level in parentheses) +!> +!> At each mass point move up vertically from the LM-TH (lowest +!> atmospheric) ETA layer. Find the ETA layers whose +!> height (above ground) bounds the target FD level height. +!> Vertically interpolate to get temperature at this FD +!> level. Average the four surrounding winds +!> to get a mass point wind. Vertically interpolate these +!> mass point winds to the target FD level. Continue this +!> process until all NFD FD levels have been processed. +!> Move on to the next mass point. +!> +!> Averaging the four above ground winds to the mass point +!> was found to smooth the field and reduce the occurrence +!> of point peak winds far in excess of the winds at +!> adjacent points. Mass point values are returned. +!> +!> NOTES for Q fields by Y Mao: +!> The following safety check should be executed by the caller of FDLVL subroutines. +!> Safety check to avoid tiny QFD values. +!> KRF: Need NCAR and NMM WRF cores in this check as well? +!> @code +!> IF(MODELNAME=='RAPR' .OR. MODELNAME=='NCAR' .OR. MODELNAME=='NMM') THEN ! +!> DO IFD = 1,NFD +!> DO J=JSTA,JEND +!> DO I=1,IM +!> if(QFD(I,J,IFD) < 1.0e-8) QFD(I,J,IFD)=0.0 +!> ENDDO +!> ENDDO +!> ENDDO +!> endif +!> @endcode +!> +!> @param[in] ITYPE Flag that determines whether MSL (1) or AGL (2) Levels are used. +!> @param[in] NFD Number of FD levels. +!> @param[in] PTFD FD pressure levels. +!> @param[in] HTFD FD height levels. +!> @param[in] NIN Number of input fields. +!> @param[in] QIN Array of mass point value on model levels. +!> @param[in] QTYPE Charater array of variable type to differentiate underground interpolation. +!>
+!>                   C-5 Cloud Species
+!>                   K-TURBULENT KINETIC ENERGY
+!>                   Q-Specific Humidity
+!>                   T-Temperature, 
+!>                   W-Vertical Velocity or Omega
+!>
+!> @param[out] QFD Array of mass point value on FD levels. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-11-23 | Russ Treadon | Corrected routine to compute FD levels with respect to mean sea level +!> 1994-01-04 | Mike Baldwin | Include options for computing either AGL or MSL +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2011-12-14 | Sarah Lu | Add GOCART aerosol AERFD +!> 2017-06-01 | Y Mao | Add FD levels for GTG(EDPARM CATEDR MWTURB) and allow levels input from control file +!> 2019-09-25 | Y Mao | Seperate mass from UV allow array of mass input to interpolate multiple fields with the same levels at one time. Dust=> AERFD can be processed when NIN=NBIN_DU +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS module +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: FDLVL_MASS COMPUTES FD LEVEL FOR MASS VARIABLES -! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES MASS VARIABLES (TEMPERATURE, SPEC. HUM...) -! ON NFD FD LEVELS. THE HEIGHT OF THESE LEVELS (IN METERS) IS -! PASSED AS AN INPUT PARAMETER. THE ALGORITHM PROCEEDS AS -! FOLLOWS. (AGL IN PARENTHESES) -! -! AT EACH MASS POINT MOVE UP VERTICALLY FROM THE LM-TH (LOWEST -! ATMOSPHERIC) ETA LAYER. FIND THE ETA LAYERS WHOSE -! HEIGHT (ABOVE GROUND) BOUNDS THE TARGET FD LEVEL HEIGHT. -! VERTICALLY INTERPOLATE TO GET TEMPERATURE AT THIS FD -! LEVEL. AVERAGE THE FOUR SURROUNDING WINDS -! TO GET A MASS POINT WIND. VERTICALLY INTERPOLATE THESE -! MASS POINT WINDS TO THE TARGET FD LEVEL. CONTINUE THIS -! PROCESS UNTIL ALL NFD FD LEVELS HAVE BEEN PROCESSED. -! MOVE ON TO THE NEXT MASS POINT. -! -! AVERAGING THE FOUR ABOVE GROUND WINDS TO THE MASS POINT -! WAS FOUND TO SMOOTH THE FIELD AND REDUCE THE OCCURRENCE -! OF POINT PEAK WINDS FAR IN EXCESS OF THE WINDS AT -! ADJACENT POINTS. MASS POINT VALUES ARE RETURNED. -! . -! -! PROGRAM HISTORY LOG: -! 92-12-22 RUSS TREADON -! 93-11-23 RUSS TREADON - CORRECTED ROUTINE TO COMPUTE -! FD LEVELS WITH REPECT TO MEAN SEA LEVEL. -! 94-01-04 MICHAEL BALDWIN - INCLUDE OPTIONS FOR COMPUTING -! EITHER AGL OR MSL -! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 11-12-14 SARAH LU - ADD GOCART AEROSOL AERFD -! 17-06-01 Y Mao - ADD FD levels for GTG(EDPARM CATEDR MWTURB) and allow -! levels input from control file -! 19-09-25 Y MAO - SEPERATE MASS FROM UV -! ALLOW ARRAY OF MASS INPUT TO INTERPOLATE MULTIPLE FIELDS -! WITH THE SAME LEVELS AT ONE TIME -! DUST=>AERFD CAN BE PROCESSED WHEN NIN=NBIN_DU -! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -! -! USAGE: CALL FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) -! INPUT ARGUMENT LIST: -! ITYPE - FLAG THAT DETERMINES WHETHER MSL (1) OR AGL (2) -! LEVELS ARE USED. -! NFD - NUMBER OF FD LEVELS -! PTFD - FD PRESSURE LEVELS -! HTFD - FD HEIGHT LEVELS -! NIN - NUMBER OF INPUT FIELDS -! QIN - ARRAY OF MASS POINT VALUE ON MODEL LEVELS -! QTYPE - CHARACTER ARRAY OF VARIABLE TYPE TO DIFFERENTIATE UNDERGROUND INTERPOLATION -! C-5 Cloud Species -! K-TURBULENT KINETIC ENERGY -! Q-Specific Humidity -! T-Temperature, -! W-Vertical Velocity or Omega -! -! OUTPUT ARGUMENT LIST: -! QFD - ARRAY OF MASS POINT VALUE ON FD LEVELS. -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! -! LIBRARY: -! COMMON - -! LOOPS -! MASKS -! OPTIONS -! INDX -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : CRAY C-90 -!$$$ -! -! - -! NOTES for Q fields by Y Mao: -! The following safety check should be executed by the caller of FDLVL subroutines. -! safety check to avoid tiny QFD values -! !KRF: Need NCAR and NMM WRF cores in this check as well? -! IF(MODELNAME=='RAPR' .OR. MODELNAME=='NCAR' .OR. MODELNAME=='NMM') THEN ! -! DO IFD = 1,NFD -! DO J=JSTA,JEND -! DO I=1,IM -! if(QFD(I,J,IFD) < 1.0e-8) QFD(I,J,IFD)=0.0 -! ENDDO -! ENDDO -! ENDDO -! endif -! - use vrbls3d, only: T,Q,ZMID,PMID,PINT,ZINT use vrbls2d, only: FIS use masks, only: LMH use params_mod, only: GI, G, GAMMA,PQ0, A2, A3, A4, RHMIN,RGAMOG use ctlblk_mod, only: JSTA, JEND, SPVAL, JSTA_2L, JEND_2U, LM, JSTA_M, & - JEND_M, IM, JM,global,MODELNAME + JEND_M, IM, JM,global,MODELNAME, & + ISTA, IEND, ISTA_2L, IEND_2U, ISTA_M, IEND_M use gridspec_mod, only: GRIDTYPE use physcons_post,only: CON_FVIRT, CON_ROG, CON_EPS, CON_EPSM1 use upp_physics, only: FPVSNEW @@ -918,9 +839,9 @@ SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) real, intent(in) :: PTFD(NFD) real,intent(in) :: HTFD(NFD) integer,intent(in) :: NIN - real,intent(in) :: QIN(IM,JSTA:JEND,LM,NIN) + real,intent(in) :: QIN(ISTA:IEND,JSTA:JEND,LM,NIN) character, intent(in) :: QTYPE(NIN) - real,intent(out) :: QFD(IM,JSTA:JEND,NFD,NIN) + real,intent(out) :: QFD(ISTA:IEND,JSTA:JEND,NFD,NIN) ! INTEGER LHL(NFD) @@ -942,7 +863,7 @@ SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) DO N=1,NIN DO IFD = 1,NFD DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QFD(I,J,IFD,N) = SPVAL ENDDO ENDDO @@ -950,13 +871,13 @@ SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) ENDDO IF(gridtype /= 'A')THEN - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF diff --git a/sorc/ncep_post.fd/FILL_PSETFLD.f b/sorc/ncep_post.fd/FILL_PSETFLD.f index 63a9757c7..bc0d3d6b9 100644 --- a/sorc/ncep_post.fd/FILL_PSETFLD.f +++ b/sorc/ncep_post.fd/FILL_PSETFLD.f @@ -1,39 +1,22 @@ !> @file -! . . . -!> SUBPROGRAM: READCNTRLgrb2_xml READS POST xml CONTROL FILE -!! PRGRMMR: J. WANG ORG: NCEP/EMC DATE: 12-01-27 -!! -!! ABSTRACT: -!! THIS ROUTINE SET THE OUTPUT FIELD GRIB2 INFORMATION SUCH -!! AS PARAMETER NAME, LEVEL TYPE ETC FROM POST AVAILABLE FIELD -!! TABLE -!! -!! PROGRAM HISTORY LOG: -!! 01_27_2012 Jun Wang - INITIAL CODE -!! 04_03_2012 Jun Wang - Add table info -!! 03_10_2015 Lin Gan - Using flat file data -!! -!! USAGE: CALL READCNTRL_XML(kth,kpv,pv) -!! INPUT ARGUMENT LIST: -!! param_ofld: output field -!! param_afld: available field in POST -!! -!! OUTPUT ARGUMENT LIST: -!! param_ofld: output field -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! MODULE: - xml_data_post_t -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM -!! +!> @brief fill_psetfld() reads post xml control file. +!> +!> This routine set the output field GRIB2 information such +!> as parameter name, level type etc from post available field +!> table. +!> +!> @param[in] param_ofld output field. +!> @param[in] param_afld available field in post. +!> @param[out] param_ofld output field. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2012-01-27 | Jun Wang | Initial +!> 2012-04-03 | Jun Wang | Add table info +!> 2015-03-10 | Lin Gan | Using flat file data +!> +!> @author J. Wang NCEP/EMC @date 2012-01-27 subroutine fill_psetfld(param_ofld,param_afld) ! diff --git a/sorc/ncep_post.fd/FIXED.f b/sorc/ncep_post.fd/FIXED.f index 356a7f403..80a9d2fde 100644 --- a/sorc/ncep_post.fd/FIXED.f +++ b/sorc/ncep_post.fd/FIXED.f @@ -16,6 +16,7 @@ !! 11-02-06 JUN WANG - grib2 option !! 20-03-25 JESSE MENG - remove grib1 !! 21-04-01 JESSE MENG - computation on defined points only +!! 21-10-15 JESSE MENG - 2D DECOMPOSITION !! !! USAGE: CALL FIXED !! INPUT ARGUMENT LIST: @@ -51,7 +52,7 @@ SUBROUTINE FIXED use params_mod, only: small, p1000, capa use lookup_mod, only: ITB,JTB,ITBQ,JTBQ use ctlblk_mod, only: jsta, jend, modelname, grib, cfld, fld_info, datapd, spval, tsrfc,& - ifhr, ifmin, lm, im, jm + ifhr, ifmin, lm, im, jm, ista, iend use rqstfld_mod, only: iget, lvls, iavblfld, id !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -72,21 +73,21 @@ SUBROUTINE FIXED IF (IGET(048)>0) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND GRID1(I,J) = GDLAT(I,J) END DO END DO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(048)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! LONGITUDE (OUTPUT GRID). CONVERT TO EAST IF (IGET(049)>0) THEN DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND IF (GDLON(I,J) < 0.)THEN GRID1(I,J) = 360. + GDLON(I,J) ELSE @@ -99,7 +100,7 @@ SUBROUTINE FIXED if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(049)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -107,7 +108,7 @@ SUBROUTINE FIXED IF (IGET(050)>0) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND GRID1(I,J) = SPVAL IF(SM(I,J) /= SPVAL) GRID1(I,J) = 1. - SM(I,J) If(MODELNAME == 'GFS' .or. MODELNAME == 'FV3R')then @@ -121,7 +122,7 @@ SUBROUTINE FIXED if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(050)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -129,14 +130,14 @@ SUBROUTINE FIXED IF (IGET(051)>0) THEN !$omp parallel do private(i,j) DO J = JSTA,JEND - DO I = 1,IM + DO I = ISTA,IEND GRID1(I,J) = SICE(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(051)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -144,14 +145,14 @@ SUBROUTINE FIXED IF (IGET(052)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = LMH(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(052)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -159,14 +160,14 @@ SUBROUTINE FIXED IF (IGET(053)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = LMV(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(053)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -177,7 +178,7 @@ SUBROUTINE FIXED IF (IGET(150)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! SNOK = AMAX1(SNO(I,J),0.0) ! SNOFAC = AMIN1(SNOK*50.0,1.0) ! EGRID1(I,J)=ALB(I,J)+(1.-VEGFRC(I,J))*SNOFAC @@ -190,11 +191,11 @@ SUBROUTINE FIXED ENDDO ENDDO ! CALL E2OUT(150,000,GRID1,GRID2,GRID1,GRID2,IM,JM) - CALL SCLFLD(GRID1,100.,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),100.,IM,JM) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(150)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -220,7 +221,7 @@ SUBROUTINE FIXED IF (ID(18)<0) ID(18) = 0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(AVGALBEDO(I,J)-SPVAL)>SMALL) THEN GRID1(I,J) = AVGALBEDO(I,J)*100. ELSE @@ -238,14 +239,14 @@ SUBROUTINE FIXED fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! IF (IGET(226)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(ALBASE(I,J)-SPVAL)>SMALL) THEN GRID1(I,J) = ALBASE(I,J)*100. ELSE @@ -256,14 +257,14 @@ SUBROUTINE FIXED if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(226)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Max snow albedo IF (IGET(227)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (ABS(MXSNAL(I,J)-SPVAL)>SMALL) THEN ! sea point, albedo=0.06 same as snow free albedo IF( (abs(SM(I,J)-1.) < 1.0E-5) ) THEN @@ -281,7 +282,7 @@ SUBROUTINE FIXED !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(MXSNAL(I,J)-SPVAL)>SMALL) THEN GRID1(I,J) = MXSNAL(I,J)*100. ELSE @@ -292,7 +293,7 @@ SUBROUTINE FIXED if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(227)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -300,7 +301,7 @@ SUBROUTINE FIXED IF (IGET(151)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SPVAL IF (MODELNAME == 'NMM') THEN IF( (abs(SM(I,J)-1.) < 1.0E-5) ) THEN @@ -317,7 +318,7 @@ SUBROUTINE FIXED if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(151)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -326,14 +327,14 @@ SUBROUTINE FIXED IF (IGET(968)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TI(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(968)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -341,14 +342,14 @@ SUBROUTINE FIXED IF (IGET(549)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FDNSST(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(549)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -356,14 +357,14 @@ SUBROUTINE FIXED IF (IGET(248)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EPSR(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(248)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF diff --git a/sorc/ncep_post.fd/FRZLVL.f b/sorc/ncep_post.fd/FRZLVL.f index d84bd7da4..507e1d086 100644 --- a/sorc/ncep_post.fd/FRZLVL.f +++ b/sorc/ncep_post.fd/FRZLVL.f @@ -1,67 +1,43 @@ !> @file -! -!> SUBPROGRAM: FRZLVL COMPUTES FRZING LVL Z AND RH -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! T. Smirnova - 8-27-2010 - added PFRZL to the output -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE FREEZING LEVEL HEIGHT AND RELATIVE -!! HUMIDITY AT THIS LEVEL FOR EACH MASS POINT ON THE ETA GRID. -!! THE COMPUTED FREEZING LEVEL HEIGHT IS THE MEAN SEA LEVEL -!! HEIGHT. AT EACH MASS POINT WE MOVE UP FROM THE SURFACE TO -!! FIND THE FIRST ETA LAYER WHERE THE TEMPERATURE IS LESS THAN -!! 273.16K. VERTICAL INTERPOLATION IN TEMPERATURE TO THE FREEZING -!! TEMPERATURE GIVES THE FREEZING LEVEL HEIGHT. PRESSURE AND -!! SPECIFIC HUMIDITY ARE INTERPOLATED TO THIS LEVEL AND ALONG WITH -!! THE TEMPERATURE PROVIDE THE FREEZING LEVEL RELATIVE HUMIDITY. -!! IF THE SURFACE (SKIN) TEMPERATURE IS BELOW FREEZING, THE ROUTINE -!! USES SURFACE BASED FIELDS TO COMPUTE THE RELATIVE HUMIDITY. -!! -!! NOTE THAT IN POSTING FREEZING LEVEL DATA THE LFM LOOK-ALIKE FILE -!! (IE, GRID 26), WE PACK 273.15K AS THE FREEZING TEMPERATURE. ALL -!! OTHER OUTPUT GRIDS USE 273.16K -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-06-10 RUSS TREADON - CORRECTED FREEZING LEVEL HEIGHTS TO BE -!! WITH REPSECT TO MEAN SEA LEVEL, NOT -!! ABOVE GROUND LEVEL. -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-08-17 MIKE BALDWIN - COMPUTE RH OVER ICE IF NECESSARY -!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! -!! USAGE: CALL FRZLVL(ZFRZ,RHFRZ) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! ZFRZ - ABOVE GROUND LEVEL FREEZING HEIGHT. -!! RHFRZ - RELATIVE HUMIDITY AT FREEZING LEVEL. -!! PFRZL - PRESSURE AT FREEZING LEVEL. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! LOOPS -!! PVRBLS -!! MASKS -!! MAPOT -!! POSTVAR -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes FRZING LVL, Z and RH. +!> +!> This routine computes the freezing level height and relative +!> humidity at this level for each mass point on the ETA grid. +!> The computed freezing level height is the mean sea level +!> height. At each mass point we move up from the surface to +!> find the first ETA layer where the temperature is less than +!> 273.16K. Vertical interpolation in temperature to the freezing +!> temperature gives the freezing level height. Pressure and +!> specific humidity are interpolated to this level and along with +!> the temperature provide the freezing level relative humidity. +!> If the surface (skin) temperature is below freezing, the routine +!> uses surface based fields to compute the relative humidity. +!> +!> Note that in posting freezing level data the LFM look-alike file +!> (IE, GRID 26), we pack 273.15K as the freezing temperature. All +!> other output grids use 273.16K. +!> +!> @param[out] ZFRZ Above ground level freezing height. +!> @param[out] RHFRZ Relative humidity at freezing level. +!> @param[out] PFRZL pressure at freezing level. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-06-05 | Russ Treadon | Corrected freezing level heights to be with respect to mean sea level, not above ground level +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 1998-08-17 | Mike Baldwin | Compute RH over ice if necessary +!> 1998-12-22 | Mike Baldwin | Back out RH over ice +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2001-10-25 | H Chuang | Modified to process hybrid model output +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2010-08-27 | T. Smirnova | Added PFRZL to the output +!> 2019-10-30 | Bo Cui | Remove "GOTO" statement +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS module +!> 2021-10-15 |JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) ! @@ -70,7 +46,7 @@ SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) use vrbls2d, only: fis, tshltr, pshltr, qshltr use masks, only: lmh use params_mod, only: gi, d00, capa, d0065, tfrz, pq0, a2, a3, a4 - use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im + use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use upp_physics, only: FPVSNEW @@ -78,7 +54,7 @@ SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) ! ! DECLARE VARIABLES. ! - REAL,dimension(im,jsta:jend) :: RHFRZ, ZFRZ, PFRZL + REAL,dimension(ista:iend,jsta:jend) :: RHFRZ, ZFRZ, PFRZL integer I,J,LLMH,L real HTSFC,PSFC,TSFC,QSFC,QSAT,RHSFC,DELZ,DELT,DELQ,DELALP, & DELZP,ZL,DZABV,QFRZ,ALPL,ALPH,ALPFRZ,PFRZ,QSFRZ,RHZ,ZU, & @@ -98,7 +74,7 @@ SUBROUTINE FRZLVL(ZFRZ,RHFRZ,PFRZL) ! & zl,zu) DO 20 J=JSTA,JEND - DO 20 I=1,IM + DO 20 I=ISTA,IEND HTSFC = FIS(I,J)*GI LLMH = NINT(LMH(I,J)) RHFRZ(I,J) = D00 diff --git a/sorc/ncep_post.fd/FRZLVL2.f b/sorc/ncep_post.fd/FRZLVL2.f index a8f934ea7..93e367513 100644 --- a/sorc/ncep_post.fd/FRZLVL2.f +++ b/sorc/ncep_post.fd/FRZLVL2.f @@ -1,66 +1,48 @@ !> @file -! -!> SUBPROGRAM: FRZLVL COMPUTES FRZING LVL Z AND RH -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE ISOTHERMAL LEVEL HEIGHT AND RELATIVE -!! HUMIDITY AT THIS LEVEL FOR EACH MASS POINT ON THE ETA GRID. -!! THE COMPUTED ISOTHERMAL LEVEL HEIGHT IS THE MEAN SEA LEVEL -!! HEIGHT. AT EACH MASS POINT WE MOVE UP FROM THE SURFACE TO -!! FIND THE LAST ETA LAYER WHERE THE TEMPERATURE IS LESS THAN -!! ISOTHERM AND THE TEMP IN THE LAYER BELOW IS ABOVE ISOTHERM. -!! VERTICAL INTERPOLATION IN TEMPERATURE TO THE ISOTHERMAL -!! TEMPERATURE GIVES THE ISOTHERMAL LEVEL HEIGHT. PRESSURE AND -!! SPECIFIC HUMIDITY ARE INTERPOLATED TO THIS LEVEL AND ALONG WITH -!! THE TEMPERATURE PROVIDE THE ISOTHERMAL LEVEL RELATIVE HUMIDITY. -!! IF THE ENTIRE ATMOSPHERE IS BELOW ISOTHERM, THE ROUTINE -!! USES SURFACE BASED FIELDS TO COMPUTE THE RELATIVE HUMIDITY. -!! -!! NOTE THAT IN POSTING FREEZING LEVEL DATA THE LFM LOOK-ALIKE FILE -!! (IE, GRID 26), WE PACK 273.15K AS THE FREEZING TEMPERATURE. ALL -!! OTHER OUTPUT GRIDS USE 273.16K -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-06-10 RUSS TREADON - CORRECTED FREEZING LEVEL HEIGHTS TO BE -!! WITH REPSECT TO MEAN SEA LEVEL, NOT -!! ABOVE GROUND LEVEL. -!! 95-03-10 MIKE BALDWIN - GET HIGHEST FREEZING LEVEL. -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-08-17 MIKE BALDWIN - COMPUTE RH OVER ICE IF NECESSARY -!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE -!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-01-15 MIKE BALDWIN - WRF VERSION -!! 10-08-27 T. Smirnova - added PFRZL to the output -!! 16-01-21 C. Alexander - Generalized function for any isotherm -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! 21-07-28 W. Meng - Restrict compuatation from undefined grids -!! -!! USAGE: CALL FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) -!! INPUT ARGUMENT LIST: -!! ISOTHERM - ISOTHERMAL VALUE OF HEIGHT TO BE OUTPUT. -!! -!! OUTPUT ARGUMENT LIST: -!! ZFRZ - ABOVE GROUND LEVE/ZFL AT ISOTHERM HEIGHT. -!! RHFRZ - RELATIVE HUMIDITY AT ISOTHERM LEVEL. -!! PFRZL - PRESSURE AT ISOTHERM LEVEL. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief Subroutine that computes FRZING LVL, Z and RH. +!> +!> This routine computes the isothermal level height and relative +!> humidity at this level for each mass point on the ETA grid. +!> The computed isothermal level height is the mean sea level +!> height. At each mass point we move up from the surface to +!> find the last ETA layer where the temperature is less than +!> isotherm and the temp in the layer below is above isotherm. +!> Vertical interpolation in temperature to the isotherm +!> temperature gives the isothermal level height. Pressure and +!> specific humidity are interpolated to this level and along with +!> the temperature provide the isothermal level relative humidity. +!> If the entire atmosphere is below isotherm, the routine +!> uses surface based fields to compute the relative humidity. +!> +!> Note that in posting freezing level data the LFM look-alike file +!> (IE, GRID 26), we pack 273.15K as the freezing temperature. All +!> other output grids use 273.16K. +!> +!> @param[in] isotherm isothermal value of height to be output. +!> @param[out] ZFRZ Above ground level/ZFL at isotherm height. +!> @param[out] RHFRZ Relative humidity at isotherm level. +!> @param[out] PFRZL pressure at isotherm level. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-06-05 | Russ Treadon | Corrected freezing level heights to be with respect to mean sea level, not above ground level +!> 1995-03-10 | Mike Baldwin | Get highest freezing level +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 1998-08-17 | Mike Baldwin | Compute RH over ice if necessary +!> 1998-12-22 | Mike Baldwin | Back out RH over ice +!> 2000-01-04 | Jim Tuccillo | MPI version +!> 2001-10-25 | H Chuang | Modified to process hybrid model output +!> 2002-01-15 | Mike Baldwin | WRF version +!> 2010-08-27 | T. Smirnova | Added PFRZL to the output +!> 2016-01-21 | C. Alexander | Generalized function for any isotherm +!> 2019-10-30 | Bo Cui | Remove "GOTO" statement +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS module +!> 2021-10-15 | JESSE MENG | 2D DECOMPOSITION +!> 2021-07-28 | W. Meng | Restrict compuatation from undefined grids +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) ! @@ -68,7 +50,7 @@ SUBROUTINE FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) use vrbls2d, only: fis, tshltr, pshltr, qz0, qs, qshltr use masks, only: lmh, sm use params_mod, only: gi, d00, capa, d0065, tfrz, pq0, a2, a3, a4, d50 - use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im + use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use upp_physics, only: FPVSNEW @@ -81,7 +63,7 @@ SUBROUTINE FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) ! REAL,PARAMETER::PUCAP=300.0E2 real,intent(in) :: ISOTHERM - REAL,dimension(im,jsta:jend),intent(out) :: RHFRZ, ZFRZ, PFRZL + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RHFRZ, ZFRZ, PFRZL !jw integer I,J,L,LICE,LLMH real HTSFC,PSFC,QSFC,RHSFC,QW,QSAT,DELZ,DELT,DELQ,DELALP,DELZP, & @@ -95,7 +77,7 @@ SUBROUTINE FRZLVL2(ISOTHERM,ZFRZ,RHFRZ,PFRZL) ! DO 20 J=JSTA,JEND - DO 20 I=1,IM + DO 20 I=ISTA,IEND IF(FIS(I,J) @file -! -!> SUBPROGRAM: GET_BITS COMPUTE NUMBER OF BITS AND ROUND FIELD. -!! PRGMMR: IREDELL ORG: W/NP23 DATE: 92-10-31 -!! -!! ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD -!! AT A PARTICULAR DECIMAL SCALING IS COMPUTED USING THE FIELD RANGE. -!! THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. -!! THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. -!! GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. -!! -!! PROGRAM HISTORY LOG: -!! 92-10-31 IREDELL -!! 95-04-14 BALDWIN - MODIFY FOLLOWING KEITH BRILL'S CODE -!! TO USE SIG DIGITS TO COMPUTE DEC SCALE -!! -!! USAGE: CALL GET_BITS(IBM,ISGDS,LEN,MG,G,ISCALE,GROUND,GMIN,GMAX,NBIT) -!! INPUT ARGUMENT LIST: -!! IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) -!! SGDS - MAXIMUM SIGNIFICANT DIGITS TO KEEP -!! (E.G. SGDS=3.0 KEEPS 3 SIGNIFICANT DIGITS) -!! OR BINARY PRECISION IF <0 -!! (E.G. SGDS=-2.0 KEEPS FIELD TO NEAREST 1/4 -!! -3.0 " " 1/8 -!! 2**SGDS PRECISION) -!! LEN - INTEGER LENGTH OF THE FIELD AND BITMAP -!! MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) -!! G - REAL (LEN) FIELD -!! -!! OUTPUT ARGUMENT LIST: -!! ISCALE - INTEGER DECIMAL SCALING -!! GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL SCALING -!! GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE -!! GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE -!! NBIT - INTEGER NUMBER OF BITS TO PACK -!! -!! SUBPROGRAMS CALLED: -!! ISRCHNE - FIND FIRST VALUE IN AN ARRAY NOT EQUAL TO TARGET VALUE -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! -!! +!> @brief get_bits() computes number of bits and round field. +!> +!> The number of bits requited to pack a given field +!> at a particular decimal scaling is computed using the field range. +!> The field is rounded off to the decimal scaling for packing. +!> The minimum and maximum rounded field values are also returned. +!> Grib bitmap masking for valid data is optionally used. +!> +!> @param[in] IBM Integer bitmap flag (=0 for no bitmap). +!> @param[in] SGDS Maximum significant digits to keep. +!>
+!> (E.G. SGDS=3.0 keeps 3 significant digits)
+!>  or binary precision if <0
+!> (E.G. SGDS=-2.0 keeps field to nearest 1/4
+!>            -3.0 keeps field to nearest 1/8
+!>            2**SGDS precision)
+!>
+!> @param[in] LEN Integer length of the field and bitmap. +!> @param[in] MG Integet (LEN) bitmap if IBM=1 (0 to skip, 1 tp keep). +!> @param[in] G Real (LEN) field. +!> @param[out] ISCALE Integer decimal scaling. +!> @param[out] GROUND Real (LEN) field rounded to decimal scaling. +!> @param[out] GMIN Real minimum valid rounded field value. +!> @param[out] GMAX Real maximum valid rounded field value. +!> @param[out] NBIT Integer number of bits to pack. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-10-31 | Iredell | Initial +!> 1995-04-14 | Baldwin | Modify following Keith Brill's code to use sig digits to compute DEC scale +!> +!> @author Iredell W/NP23 @date 1992-10-31 SUBROUTINE GET_BITS(IBM,SGDS,LEN,MG,G,ISCALE,GROUND, & GMIN,GMAX,NBIT) @@ -91,43 +82,36 @@ SUBROUTINE GET_BITS(IBM,SGDS,LEN,MG,G,ISCALE,GROUND, & ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END - SUBROUTINE FNDBIT ( rmin, rmax, rdb, nmbts, iscale, iret ) -!************************************************************************ -!* FNDBIT * -!* * -!* This subroutine computes the number of packing bits given the * -!* maximum number of significant digits to preserve or the binary * -!* precision to store the data. The binary precision is given as a * -!* negative integer, ISCALE will always be zero in this case. * -!* * -!* The binary precision translates as follows: * -!* -1 => store data to nearest 1/2 * -!* -2 => store data to nearest 1/4 * -!* -3 => store data to nearest 1/8 * -!* * -!* Note that a fractional number of significant digits is allowed. * -!* * -!* FNDBIT ( AMIN, AMAX, RDB, NBITS, ISCALE, IRET ) * -!* * -!* Input parameters: * -!* AMIN REAL Minimum value * -!* AMAX REAL Maximum value * -!* RDB REAL Maximum # of significant digits * -!* OR binary precision if < 0 * -!* * -!* Output parameters: * -!* NBITS INTEGER Number of bits for packing * -!* ISCALE INTEGER Power of 10 scaling to use * -!* IRET INTEGER Return code * -!* 0 = normal return * -!** * -!* Log: * -!* K. Brill/NMC 06/92 * -!* K. Brill/EMC 12/95 Added binary precision * -!* M. Baldwin 10/96 Added fix for negative nmbts -!************************************************************************ -!* -! +!> fndbit() computes the number of packing bits given the +!> maximum number of significant digits to preserve or the binary +!> precision to store the data. The binary precision is given as a +!> negative integer, ISCALE will always be zero in this case. +!> +!> The binary precision translates as follows: +!> 
+!>     -1  =>  store data to nearest 1/2
+!>     -2  =>  store data to nearest 1/4
+!>     -3  =>  store data to nearest 1/8
+!>
+!> +!> Note that a fractional number of significant digits is allowed. +!> +!> @param[in] AMIN Real Minimum value. +!> @param[in] AMAX Real Maximum value. +!> @param[in] RDB Real Maximum # of significant digits OR binary precision if < 0. +!> @param[out] NBITS Integer Number of bits for packing. +!> @param[out] ISCALE Integer Power of 10 scaling to use. +!> @param[out] IRET Integer Return code. 0 = normal return. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-06-?? | K Brill | Initial +!> 1995-12-?? | K Brill | Added binary precision +!> 1996-10-?? | M Baldwin | Added fix for negative nmbts +!> +!> @author K. Brill NMC @date 1992-06-?? + SUBROUTINE FNDBIT ( rmin, rmax, rdb, nmbts, iscale, iret ) implicit none ! integer,intent(inout) :: iscale,nmbts diff --git a/sorc/ncep_post.fd/GFSPOST.F b/sorc/ncep_post.fd/GFSPOST.F index 9921a3228..c64d13b7d 100644 --- a/sorc/ncep_post.fd/GFSPOST.F +++ b/sorc/ncep_post.fd/GFSPOST.F @@ -1,57 +1,43 @@ !> @file -! -!> Subprogram: pvetc Compute potential vorticity, etc -!! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -!! -!! Abstract: This subprogram computes -!! the Montgomery streamfunction -!! hm=cp*t+g*z -!! the specific entropy -!! s=cp*log(t/t0)-r*log(p/p0) -!! the Brunt-Vaisala frequency squared -!! bvf2=g/cp*ds/dz -!! the potential vorticity defined as -!! pvn=(av*ds/dz-dv/dz*ds/dx+du/dz*ds/dy)/rho/cp -!! the potential temperature -!! theta=t0*exp(s/cp) -!! the static stability -!! sigma=t/g*bvf2 -!! and the potential vorticity in PV units -!! pvu=10**-6*theta*pvn -!! -!! Program history log: -!! 1999-10-18 Mark Iredell -!! -!! Usage: call pvetc(km,p,px,py,t,tx,ty,h,u,v,av,s,bvf2,pvn,theta,sigma,pvu) -!! Input argument list: -!! km integer number of levels -!! p real (km) pressure (Pa) -!! px real (km) pressure x-gradient (Pa/m) -!! py real (km) pressure y-gradient (Pa/m) -!! t real (km) (virtual) temperature (K) -!! tx real (km) (virtual) temperature x-gradient (K/m) -!! ty real (km) (virtual) temperature y-gradient (K/m) -!! h real (km) height (m) -!! u real (km) x-component wind (m/s) -!! v real (km) y-component wind (m/s) -!! av real (km) absolute vorticity (1/s) -!! Output argument list: -!! hm real (km) Montgomery streamfunction (m**2/s**2) -!! s real (km) specific entropy (J/K/kg) -!! bvf2 real (km) Brunt-Vaisala frequency squared (1/s**2) -!! pvn real (km) potential vorticity (m**2/kg/s) -!! theta real (km) (virtual) potential temperature (K) -!! sigma real (km) static stability (K/m) -!! pvu real (km) potential vorticity (10**-6*K*m**2/kg/s) -!! -!! Modules used: -!! physcons Physical constants -!! -!! Attributes: -!! Language: Fortran 90 -!! -!! - subroutine pvetc(km,p,px,py,t,tx,ty,h,u,v,av,hm,s,bvf2,pvn,theta,sigma,pvu) +!> pvetc() computes potential vorticity, etc. +!> +!> This subprogram computes +!> computation | equation +!> -----------------|------------ +!> Montgomery streamfunction | hm=cp*t+g*z +!> Specific entropy | s=cp*log(t/t0)-r*log(p/p0) +!> Brunt-Vaisala frequency squared | bvf2=g/cp*ds/dz +!> Potential vorticity | pvn=(av*ds/dz-dv/dz*ds/dx+du/dz*ds/dy)/rho/cp +!> Potential temperature | theta=t0*exp(s/cp) +!> Static stability | sigma=t/g*bvf2 +!> Potential vorticity in PV units | pvu=10**-6*theta*pvn +!> +!> @param[in] km integer number of levels. +!> @param[in] p real (km) pressure (Pa). +!> @param[in] px real (km) pressure x-gradient (Pa/m). +!> @param[in] py real (km) pressure y-gradient (Pa/m). +!> @param[in] t real (km) (virtual) temperature (K). +!> @param[in] tx real (km) (virtual) temperature x-gradient (K/m). +!> @param[in] ty real (km) (virtual) temperature y-gradient (K/m). +!> @param[in] h real (km) height (m). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[in] av real (km) absolute vorticity (1/s). +!> @param[out] hm real (km) Montgomery streamfunction (m**2/s**2). +!> @param[out] s real (km) specific entropy (J/K/kg). +!> @param[out] bvf2 real (km) Brunt-Vaisala frequency squared (1/s**2). +!> @param[out] pvn real (km) potential vorticity (m**2/kg/s). +!> @param[out] theta real (km) (virtual) potential temperature (K). +!> @param[out] sigma real (km) static stability (K/m). +!> @param[out] pvu real (km) potential vorticity (10**-6*K*m**2/kg/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> +!> @author Mark Iredell np23 @date 1999-10-18 + subroutine pvetc(km,p,px,py,t,tx,ty,h,u,v,av,hm,s,bvf2,pvn,theta,sigma,pvu) use physcons_post, only: con_cp, con_g, con_rd, con_rocp ! @@ -91,46 +77,37 @@ subroutine pvetc(km,p,px,py,t,tx,ty,h,u,v,av,hm,s,bvf2,pvn,theta,sigma,pvu) enddo end subroutine ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine p2th(km,theta,u,v,h,t,pvu,sigma,rh,omga,kth,th & +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!> p2th() interpolates to isentropic level. +!> +!> This subprogram interpolates fields to given isentropic levels. +!> The interpolation is linear in entropy. +!> Outside the domain the bitmap is set to false. +!> +!> @param[in] km integer number of levels. +!> @param[in] theta real (km) potential temperature (K). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[in] h real (km) height (m). +!> @param[in] t real (km) temperature (K). +!> @param[in] pvu real (km) potential vorticity in PV units (10**-6*K*m**2/kg/s). +!> @param[in] kth integer number of isentropic levels. +!> @param[in] th real (kth) isentropic levels (K). +!> @param[out] lpv logical*1 (kth) bitmap. +!> @param[out] uth real (kth) x-component wind (m/s). +!> @param[out] vth real (kth) y-component wind (m/s). +!> @param[out] hth real (kth) height (m). +!> @param[out] tth real (kth) temperature (K). +!> @param[out] zth real (kth) potential vorticity in PV units (10**-6*K*m**2/kg/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> +!> @author Mark Iredell np23 @date 1999-10-18 + subroutine p2th(km,theta,u,v,h,t,pvu,sigma,rh,omga,kth,th & ,lth,uth,vth,hth,tth,zth,sigmath,rhth,oth) -!$$$ Subprogram documentation block -! -! Subprogram: p2th Interpolate to isentropic level -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram interpolates fields to given isentropic levels. -! The interpolation is linear in entropy. -! Outside the domain the bitmap is set to false. -! -! Program history log: -! 1999-10-18 Mark Iredell -! -! Usage: call p2th(km,theta,u,v,h,t,puv,kth,th,uth,vth,tth) -! Input argument list: -! km integer number of levels -! theta real (km) potential temperature (K) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! h real (km) height (m) -! t real (km) temperature (K) -! pvu real (km) potential vorticity in PV units (10**-6*K*m**2/kg/s) -! kth integer number of isentropic levels -! th real (kth) isentropic levels (K) -! Output argument list: -! lpv logical*1 (kth) bitmap -! uth real (kth) x-component wind (m/s) -! vth real (kth) y-component wind (m/s) -! hth real (kth) height (m) -! tth real (kth) temperature (K) -! zth real (kth) potential vorticity in PV units (10**-6*K*m**2/kg/s) -! -! Subprograms called: -! rsearch1 search for a surrounding real interval -! -! Attributes: -! Language: Fortran 90 -! -!$$$ implicit none integer,intent(in):: km,kth real,intent(in),dimension(km):: theta,u,v,h,t,pvu,sigma,rh,omga @@ -161,55 +138,42 @@ subroutine p2th(km,theta,u,v,h,t,pvu,sigma,rh,omga,kth,th & enddo end subroutine ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine p2pv(km,pvu,h,t,p,u,v,kpv,pv,pvpt,pvpb,& +!> p2pv() interpolates to potential vorticity level. +!> +!> This subprogram interpolates fields to given potential vorticity +!> levels within given pressure limits. +!> The output level is the first encountered from the top pressure limit. +!> If the given potential vorticity level is not found, the outputs are zero +!> and the bitmap is false. The interpolation is linear in potential vorticity. +!> +!> @param[in] km integer number of levels. +!> @param[in] pvu real (km) potential vorticity in PV units (10**-6*K*m**2/kg/s). +!> @param[in] h real (km) height (m). +!> @param[in] t real (km) temperature (K). +!> @param[in] p real (km) pressure (Pa). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[in] kpv integer number of potential vorticity levels. +!> @param[in] pv real (kpv) potential vorticity levels (10**-6*K*m**2/kg/s). +!> @param[in] pvpt real (kpv) top pressures for PV search (Pa). +!> @param[in] pvpb real (kpv) bottom pressures for PV search (Pa). +!> @param[out] lpv logical*1 (kpv) bitmap. +!> @param[out] upv real (kpv) x-component wind (m/s). +!> @param[out] vpv real (kpv) y-component wind (m/s). +!> @param[out] hpv real (kpv) temperature (K). +!> @param[out] tpv real (kpv) temperature (K). +!> @param[out] ppv real (kpv) pressure (Pa). +!> @param[out] spv real (kpv) wind speed shear (1/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> 2021-08-31 | Hui-ya Chuang | Increase depth criteria for identifying PV layer from 25 to 50 to avoid finding shallow high level PV layer in high latitudes +!> +!> @author Mark Iredell np23 @date 1999-10-18 + subroutine p2pv(km,pvu,h,t,p,u,v,kpv,pv,pvpt,pvpb,& lpv,upv,vpv,hpv,tpv,ppv,spv) -!$$$ Subprogram documentation block -! -! Subprogram: p2pv Interpolate to potential vorticity level -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram interpolates fields to given potential vorticity -! levels within given pressure limits. -! The output level is the first encountered from the top pressure limit. -! If the given potential vorticity level is not found, the outputs are zero -! and the bitmap is false. The interpolation is linear in potential vorticity. -! -! Program history log: -! 1999-10-18 Mark Iredell -! 2021-08-31 Hui-ya Chuang Increase depth criteria for identifying PV layer -! from 25 to 50 to avoid finding shallow high level -! PV layer in high latitudes -! -! Usage: call p2pv(km,pvu,h,t,p,u,v,kpv,pv,pvpt,pvpb,& -! lpv,upv,vpv,hpv,tpv,ppv,spv) -! Input argument list: -! km integer number of levels -! pvu real (km) potential vorticity in PV units (10**-6*K*m**2/kg/s) -! h real (km) height (m) -! t real (km) temperature (K) -! p real (km) pressure (Pa) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! kpv integer number of potential vorticity levels -! pv real (kpv) potential vorticity levels (10**-6*K*m**2/kg/s) -! pvpt real (kpv) top pressures for PV search (Pa) -! pvpb real (kpv) bottom pressures for PV search (Pa) -! Output argument list: -! lpv logical*1 (kpv) bitmap -! upv real (kpv) x-component wind (m/s) -! vpv real (kpv) y-component wind (m/s) -! hpv real (kpv) temperature (K) -! tpv real (kpv) temperature (K) -! ppv real (kpv) pressure (Pa) -! spv real (kpv) wind speed shear (1/s) -! -! Subprograms called: -! rsearch1 search for a surrounding real interval -! -! Attributes: -! Language: Fortran 90 -! -!$$$ use physcons_post, only: con_rog implicit none integer,intent(in):: km,kpv @@ -276,58 +240,33 @@ subroutine p2pv(km,pvu,h,t,p,u,v,kpv,pv,pvpt,pvpb,& !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- -subroutine rsearch1(km1,z1,km2,z2,l2) -!$$$ subprogram documentation block -! -! subprogram: rsearch1 search for a surrounding real interval -! prgmmr: iredell org: w/nmc23 date: 98-05-01 -! -! abstract: this subprogram searches a monotonic sequences of real numbers -! for intervals that surround a given search set of real numbers. -! the sequences may be monotonic in either direction; the real numbers -! may be single or double precision. -! -! program history log: -! 1999-01-05 mark iredell -! -! usage: call rsearch1(km1,z1,km2,z2,l2) -! input argument list: -! km1 integer number of points in the sequence -! z1 real (km1) sequence values to search -! (z1 must be monotonic in either direction) -! km2 integer number of points to search for -! z2 real (km2) set of values to search for -! (z2 need not be monotonic) -! -! output argument list: -! l2 integer (km2) interval locations from 0 to km1 -! (z2 will be between z1(l2) and z1(l2+1)) -! -! subprograms called: -! sbsrch essl binary search -! dbsrch essl binary search -! -! remarks: -! returned values of 0 or km1 indicate that the given search value -! is outside the range of the sequence. -! -! if a search value is identical to one of the sequence values -! then the location returned points to the identical value. -! if the sequence is not strictly monotonic and a search value is -! identical to more than one of the sequence values, then the -! location returned may point to any of the identical values. -! -! if l2(k)=0, then z2(k) is less than the start point z1(1) -! for ascending sequences (or greater than for descending sequences). -! if l2(k)=km1, then z2(k) is greater than or equal to the end point -! z1(km1) for ascending sequences (or less than or equal to for -! descending sequences). otherwise z2(k) is between the values -! z1(l2(k)) and z1(l2(k+1)) and may equal the former. -! -! attributes: -! language: fortran -! -!$$$ +!> rsearch1() searches for a surrounding real interval. +!> +!> This subprogram searches a monotonic sequences of real numbers +!> for intervals that surround a given search set of real numbers. +!> the sequences may be monotonic in either direction; the real numbers +!> may be single or double precision. +!> +!> @param[in] km1 integer number of points in the sequence. +!> @param[in] z1 real (km1) sequence values to search. (z1 must be monotonic in either direction) +!> @param[in] km2 integer number of points to search for. +!> @param[in] z2 real (km2) set of values to search for. (z2 need not be monotonic) +!> @param[out] l2 integer (km2) interval locations from 0 to km1. (z2 will be between z1(l2) and z1(l2+1)) +!> +!> @note +!> * Returned values of 0 or km1 indicate that the given search value is outside the range of the sequence. +!> * If a search value is identical to one of the sequence values then the location returned points to the identical value. +!> * If the sequence is not strictly monotonic and a search value is identical to more than one of the sequence values, then the location returned may point to any of the identical values. +!> * If l2(k)=0, then z2(k) is less than the start point z1(1) for ascending sequences (or greater than for descending sequences). +!> * If l2(k)=km1, then z2(k) is greater than or equal to the end point z1(km1) for ascending sequences (or less than or equal to for descending sequences). Otherwise z2(k) is between the values z1(l2(k)) and z1(l2(k+1)) and may equal the former. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1998-05-01 | Mark Iredell | Initial +!> +!> @author Mark Iredell w/nmc23 @date 1998-05-01 + subroutine rsearch1(km1,z1,km2,z2,l2) implicit none integer,intent(in):: km1,km2 real,intent(in):: z1(km1),z2(km2) @@ -371,51 +310,38 @@ subroutine rsearch1(km1,z1,km2,z2,l2) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine tpause(km,p,u,v,t,h,ptp,utp,vtp,ttp,htp,shrtp) -!$$$ Subprogram documentation block -! -! Subprogram: tpause Compute tropopause level fields -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram finds the tropopause level and computes fields -! at the tropopause level. The tropopause is defined as the lowest level -! above 500 mb which has a temperature lapse rate of less than 2 K/km. -! The lapse rate must average less than 2 K/km over a 2 km depth. -! If no such level is found below 50 mb, the tropopause is set to 50 mb. -! The tropopause fields are interpolated linearly in lapse rate. -! The tropopause pressure is found hydrostatically. -! The tropopause wind shear is computed as the partial derivative -! of wind speed with respect to height at the tropopause level. -! -! Program history log: -! 1999-10-18 Mark Iredell -! -! Usage: call tpause(km,p,u,v,t,h,ptp,utp,vtp,ttp,htp,shrtp) -! Input argument list: -! km integer number of levels -! p real (km) pressure (Pa) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! t real (km) temperature (K) -! h real (km) height (m) -! Output argument list: -! ptp real tropopause pressure (Pa) -! utp real tropopause x-component wind (m/s) -! vtp real tropopause y-component wind (m/s) -! ttp real tropopause temperature (K) -! htp real tropopause height (m) -! shrtp real tropopause wind shear (1/s) -! -! Files included: -! physcons.h Physical constants -! -! Subprograms called: -! rsearch1 search for a surrounding real interval -! -! Attributes: -! Language: Fortran 90 -! -!$$$ +!> tpause() computes tropopause level fields. +!> +!> This subprogram finds the tropopause level and computes fields +!> at the tropopause level. The tropopause is defined as the lowest level +!> above 500 mb which has a temperature lapse rate of less than 2 K/km. +!> The lapse rate must average less than 2 K/km over a 2 km depth. +!> If no such level is found below 50 mb, the tropopause is set to 50 mb. +!> The tropopause fields are interpolated linearly in lapse rate. +!> The tropopause pressure is found hydrostatically. +!> The tropopause wind shear is computed as the partial derivative +!> of wind speed with respect to height at the tropopause level. +!> +!> @param[in] km integer number of levels. +!> @param[in] p real (km) pressure (Pa). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[in] t real (km) temperature (K). +!> @param[in] h real (km) height (m). +!> @param[out] ptp real tropopause pressure (Pa). +!> @param[out] utp real tropopause x-component wind (m/s). +!> @param[out] vtp real tropopause y-component wind (m/s). +!> @param[out] ttp real tropopause temperature (K). +!> @param[out] htp real tropopause height (m). +!> @param[out] shrtp real tropopause wind shear (1/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> +!> @author Mark Iredell np23 @date 1999-10-18 + subroutine tpause(km,p,u,v,t,h,ptp,utp,vtp,ttp,htp,shrtp) use physcons_post, only: con_rog implicit none integer,intent(in):: km @@ -473,49 +399,36 @@ subroutine tpause(km,p,u,v,t,h,ptp,utp,vtp,ttp,htp,shrtp) shrtp=(spdu-spdd)/(h(ktp)-h(ktp+1)) end subroutine ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine mxwind(km,p,u,v,t,h,pmw,umw,vmw,tmw,hmw) -!$$$ Subprogram documentation block -! -! Subprogram: mxwind Compute maximum wind level fields -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram finds the maximum wind level and computes fields -! at the maximum wind level. The maximum wind level is searched for -! between 500 mb and 100 mb. The height and wind speed at the maximum wind -! speed level is calculated by assuming the wind speed varies quadratically -! in height in the neighborhood of the maximum wind level. The other fields -! are interpolated linearly in height to the maximum wind level. -! The maximum wind level pressure is found hydrostatically. -! -! Program history log: -! 1999-10-18 Mark Iredell -! 2005-02-02 Mark Iredell changed upper limit to 100 mb -! -! Usage: call mxwind(km,p,u,v,t,h,pmw,umw,vmw,tmw,hmw) -! Input argument list: -! km integer number of levels -! p real (km) pressure (Pa) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! t real (km) temperature (K) -! h real (km) height (m) -! Output argument list: -! pmw real maximum wind level pressure (Pa) -! umw real maximum wind level x-component wind (m/s) -! vmw real maximum wind level y-component wind (m/s) -! tmw real maximum wind level temperature (K) -! hmw real maximum wind level height (m) -! -! Files included: -! physcons.h Physical constants -! -! Subprograms called: -! rsearch1 search for a surrounding real interval -! -! Attributes: -! Language: Fortran 90 -! -!$$$ +!> mxwind() computes maximum wind level fields. +!> +!> This subprogram finds the maximum wind level and computes fields +!> at the maximum wind level. The maximum wind level is searched for +!> between 500 mb and 100 mb. The height and wind speed at the maximum wind +!> speed level is calculated by assuming the wind speed varies quadratically +!> in height in the neighborhood of the maximum wind level. The other fields +!> are interpolated linearly in height to the maximum wind level. +!> The maximum wind level pressure is found hydrostatically. +!> +!> @param[in] km integer number of levels. +!> @param[in] p real (km) pressure (Pa). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[in] t real (km) temperature (K). +!> @param[in] h real (km) height (m). +!> @param[out] pmw real maximum wind level pressure (Pa). +!> @param[out] umw real maximum wind level x-component wind (m/s). +!> @param[out] vmw real maximum wind level y-component wind (m/s). +!> @param[out] tmw maximum wind level temperature (K). +!> @param[out] hmw real maximum wind level height (m). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> 2005-02-02 | Mark Iredell | Changed upper limit to 100 mb +!> +!> @author Mark Iredell np23 @date 1999-10-18 + subroutine mxwind(km,p,u,v,t,h,pmw,umw,vmw,tmw,hmw) use physcons_post, only: con_rog implicit none integer,intent(in):: km @@ -576,40 +489,34 @@ subroutine mxwind(km,p,u,v,t,h,pmw,umw,vmw,tmw,hmw) tmw=t(kmw)-wmw*(t(kmw)-t(kmw+1)) pmw=p(kmw)*exp((h(kmw)-hmw)*(1-0.5*(tmw/t(kmw)-1))/(con_rog*t(kmw))) end subroutine - -subroutine mptgen(mpirank,mpisize,nd,jt1,jt2,j1,j2,jx,jm,jn) -!$$$ Subprogram documentation block -! -! Subprogram: mptgen Generate grid decomposition dimensions -! Prgmmr: Iredell Org: W/NP23 Date: 1999-02-12 -! -! Abstract: This subprogram decomposes total dimensions of a problem -! into smaller domains to be managed on a distributed memory system. -! The last dimension given is decomposed first. If more decompositions -! are possible, the next to last dimension is decomposed next, and so on. -! The transpositions between decompositions should be done by mptran*. -! -! Program history log: -! 1999-02-12 Mark Iredell -! -! Usage: call mptgen(mpirank,mpisize,nd,jt1,jt2,j1,j2,jx,jm,jn) -! Input argument list: -! mpirank integer(kint_mpi) rank of the process (from mpi_comm_rank) -! mpisize integer(kint_mpi) size of the process (from mpi_comm_size) -! nd integer(kint_mpi) number of dimensions to decompose -! jt1 integer(kint_mpi) (nd) lower bounds of total dimensions -! jt2 integer(kint_mpi) (nd) upper bounds of total dimensions -! Output argument list: -! j1 integer(kint_mpi) (nd) lower bounds of local decompositions -! j2 integer(kint_mpi) (nd) upper bounds of local decompositions -! jx integer(kint_mpi) (nd) local size of decompositions -! jm integer(kint_mpi) (nd) maximum size of decompositions -! jn integer(kint_mpi) (nd) number of decompositions -! -! Attributes: -! Language: Fortran 90 -! -!$$$ + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!> mptgen() generates grid decomposition dimensions. +!> +!> This subprogram decomposes total dimensions of a problem +!> into smaller domains to be managed on a distributed memory system. +!> The last dimension given is decomposed first. If more decompositions +!> are possible, the next to last dimension is decomposed next, and so on. +!> The transpositions between decompositions should be done by mptran*. +!> +!> @param[in] mpirank integer(kint_mpi) rank of the process (from mpi_comm_rank). +!> @param[in] mpisize integer(kint_mpi) size of the process (from mpi_comm_size). +!> @param[in] nd integer(kint_mpi) number of dimensions to decompose. +!> @param[in] jt1 integer(kint_mpi) (nd) lower bounds of total dimensions. +!> @param[in] jt2 integer(kint_mpi) (nd) upper bounds of total dimensions. +!> @param[out] j1 integer(kint_mpi) (nd) lower bounds of local decompositions. +!> @param[out] j2 integer(kint_mpi) (nd) upper bounds of local decompositions. +!> @param[out] jx integer(kint_mpi) (nd) local size of decompositions. +!> @param[out] jm integer(kint_mpi) (nd) maximum size of decompositions. +!> @param[out] jn integer(kint_mpi) (nd) number of decompositions. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-02-12 | Mark Iredell | Initial +!> +!> @author Mark Iredell np23 @date 1999-02-12 + subroutine mptgen(mpirank,mpisize,nd,jt1,jt2,j1,j2,jx,jm,jn) use machine_post,only:kint_mpi implicit none integer(kint_mpi),intent(in):: mpirank,mpisize,nd,jt1(nd),jt2(nd) @@ -642,91 +549,77 @@ subroutine mptgen(mpirank,mpisize,nd,jt1,jt2,j1,j2,jx,jm,jn) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine !------------------------------------------------------------------------------- -subroutine mptranr4(mpicomm,mpisize,im,ida,idb,& - jm,jma,jmb,jda,km,kma,kmb,kdb,a,b,ta,tb) -!$$$ Subprogram documentation block -! -! Subprogram: mptranr4 Transpose grid decompositions -! Prgmmr: Iredell Org: W/NP23 Date: 1999-02-12 -! -! Abstract: This subprogram transposes an array of data from one -! grid decomposition to another by using message passing. -! The grid decompositions should be generated by mptgen. -! -! Program history log: -! 1999-02-12 Mark Iredell -! -! Usage: call mptranr4(mpicomm,mpisize,im,ida,idb,& -! jm,jma,jmb,jda,km,kma,kmb,kdb,a,b) -! Input argument list: -! mpicomm integer(kint_mpi) mpi communicator -! mpisize integer(kint_mpi) size of the process (from mpi_comm_size) -! im integer(kint_mpi) undecomposed range -! ida integer(kint_mpi) undecomposed input dimension -! idb integer(kint_mpi) undecomposed output dimension -! jm integer(kint_mpi) output grid decomposition size -! jma integer(kint_mpi) input grid undecomposed range -! jmb integer(kint_mpi) output grid decomposed range -! jda integer(kint_mpi) input grid undecomposed dimension -! km integer(kint_mpi) input grid decomposition size -! kma integer(kint_mpi) input grid decomposed range -! kmb integer(kint_mpi) output grid undecomposed range -! kdb integer(kint_mpi) output grid undecomposed dimension -! a real(4) (ida,jda,kma) input array -! Output argument list: -! b real(4) (idb,kdb,jmb) output array -! ta,tb real(4) (im,jm,km,mpisize) work arrays -! -! Subprograms called: -! mpi_alltoall mpi exchange of data between every process pair -! -! Remarks: -! While this routine serves a wide variety of scalable transpose functions -! for multidimensional grids, -! (a) it does not work with nonrectanguloid grids; -! (b) it does not do any load balancing; -! (c) it does not do any communication hiding. -! -! This subprogram must be used rather than mpi_alltoall -! in any of the following cases: -! (a) The undecomposed range is less than the respective dimension -! (either im1 or jm>1) -! (c) The decomposed range is ever zero -! (either kma==0 or jmb==0 for any process) -! (d) The output grid range is not the full extent -! (either kmb mptranr4() transposes grid decompositions. +!> +!> This subprogram transposes an array of data from one +!> grid decomposition to another by using message passing. +!> The grid decompositions should be generated by mptgen. +!> +!> @param[in] mpicomm integer(kint_mpi) mpi communicator. +!> @param[in] mpisize integer(kint_mpi) size of the process (from mpi_comm_size). +!> @param[in] im integer(kint_mpi) undecomposed range. +!> @param[in] ida integer(kint_mpi) undecomposed input dimension. +!> @param[in] idb integer(kint_mpi) undecomposed output dimension. +!> @param[in] jm integer(kint_mpi) output grid decomposition size. +!> @param[in] jma integer(kint_mpi) input grid undecomposed range. +!> @param[in] jmb integer(kint_mpi) output grid decomposed range. +!> @param[in] jda integer(kint_mpi) input grid undecomposed dimension. +!> @param[in] km integer(kint_mpi) input grid decomposition size. +!> @param[in] kma integer(kint_mpi) input grid decomposed range. +!> @param[in] kmb integer(kint_mpi) output grid undecomposed range. +!> @param[in] kdb integer(kint_mpi) output grid undecomposed dimension. +!> @param[in] a real(4) (ida,jda,kma) input array. +!> @param[out] b real(4) (idb,kdb,jmb) output array. +!> @param[out] ta,tb real(4) (im,jm,km,mpisize) work arrays. +!> +!> @note +!> While this routine serves a wide variety of scalable transpose functions for multidimensional grids, +!> * It does not work with nonrectanguloid grids; +!> * It does not do any load balancing; +!> * It does not do any communication hiding. +!> +!> This subprogram must be used rather than mpi_alltoall in any of the following cases: +!> +!> * The undecomposed range is less than the respective dimension (either im * The decomposition size is greater than one (either km>1 or jm>1) +!> * The decomposed range is ever zero (either kma==0 or jmb==0 for any process) +!> * The output grid range is not the full extent (either kmb +!> If none of these conditions apply, mpi_alltoall could be used directly rather than this subprogram and would be more efficient. +!> @note +!> Example 1. Transpose a 1000 x 10000 matrix. +!> 
+!>  include 'mpif.h'                                     ! use mpi
+!>  parameter(jt=1000,kt=10000)                          ! set problem size
+!>  real,allocatable:: a(:,:),b(:,:)                     ! declare arrays
+!>  call mpi_init(ierr)                                  ! initialize mpi
+!>  call mpi_comm_rank(MPI_COMM_WORLD,mpirank,ierr)      ! get mpi rank
+!>  call mpi_comm_size(MPI_COMM_WORLD,mpisize,ierr)      ! get mpi size
+!>  call mptgen(mpirank,mpisize,1,1,jt,j1,j2,jx,jm,jn)   ! decompose output
+!>  call mptgen(mpirank,mpisize,1,1,kt,k1,k2,kx,km,kn)   ! decompose input
+!>  allocate(a(jt,k1:k2),b(kt,j1:j2))                    ! allocate arrays
+!>  a=reshape((/((j+k,j=1,jt),k=k1,k2)/),(/jt,k2-k1+1/)) ! initialize input
+!>  call mptranr4(MPI_COMM_WORLD,mpisize,1,1,1,          ! transpose arrays
+!>  &              jm,jt,j2-j1+1,jt,km,k2-k1+1,kt,kt,a,b)
+!>  print '(2i8,f16.1)',((k,j,b(k,j),k=2000,kt,2000),    ! print some values
+!>  &                    j=((j1-1)/200+1)*200,j2,200)
+!>  call mpi_finalize(ierr)                              ! finalize mpi
+!>  end
+!>
+!> This transpose took 0.6 seconds on 4 2-way winterhawk nodes. +!> @note +!> A 20000x10000 transpose took 3.4 seconds on 16 2-way winterhawk nodes. +!> @note +!> Thus a transpose may take about 1 second for every 16 Mb per node. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-02-12 | Mark Iredell | Initial +!> +!> @author Mark Iredell np23 @date 1999-02-12 + subroutine mptranr4(mpicomm,mpisize,im,ida,idb,& + jm,jma,jmb,jda,km,kma,kmb,kdb,a,b,ta,tb) use machine_post,only:kint_mpi implicit none include 'mpif.h' diff --git a/sorc/ncep_post.fd/GFSPOSTSIG.F b/sorc/ncep_post.fd/GFSPOSTSIG.F index 50b6f358a..5ca911777 100644 --- a/sorc/ncep_post.fd/GFSPOSTSIG.F +++ b/sorc/ncep_post.fd/GFSPOSTSIG.F @@ -1,77 +1,54 @@ !> @file -! -!> Subprogram: rtsig Read and transform sigma file -!! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -!! -!! Abstract: This subprogram reads a sigma file and transforms -!! the fields to a designated global grid. -!! -!! Program history log: -!! 1999-10-18 Mark Iredell -!! 2013-04-19 Jun Wang: add option to get tmp and ps(in pascal) -!! from enthalpy and ps(cb) option -!! 2013-05-06 Shrinivas Moorthi: Initialize midea to 0 -!! 2013-05-07 Shrinivas Moorthi: Remove mo3, mct, midea and define io3, ict etc -!! correctly and get correct cloud condensate. -!! 2013-08-02 Shrinivas Moorthi: Rewrote the whole routine to read the sigma -!! file differently and to read all tracers -!! Addedd sptezj for two 2d fields -!! 2014-02-20 Shrinivas Moorthi: Modified conversion from spectral to grid -!! taking advantage of threding in SP library. -!! This really speeds up the code -!! Also threaded loop for Temperature from Tv - -!! -!! Usage: call rtsig(lusig,head,k1,k2,kgds,ijo,nct, & -!! h,p,px,py,t,tx,ty,u,v,d,z,sh,o3,ct,iret,o,o2) -!! Input argument list: -!! lusig integer(sigio_intkind) sigma file unit number -!! head type(sigio_head) sigma file header -!! k1 integer first model level to return -!! k2 integer last model level to return -!! kgds integer (200) GDS to which to transform -!! ijo integer dimension of output fields -!! levs integer number of total vertical levels -!! ntrac integer number of output tracers -!! jcap integer number of waves -!! lnt2 integer (jcap+1)*(jcap+2) -!! Output argument list: -!! h real (ijo) surface orography (m) -!! p real (ijo) surface pressure (Pa) -!! px real (ijo) log surface pressure x-gradient (1/m) -!! py real (ijo) log surface pressure y-gradient (1/m) -!! t real (ijo,k1:k2) temperature (K) -!! tx real (ijo,k1:k2) virtual temperature x-gradient (K/m) -!! ty real (ijo,k1:k2) virtual temperature y-gradient (K/m) -!! u real (ijo,k1:k2) x-component wind (m/s) -!! v real (ijo,k1:k2) y-component wind (m/s) -!! d real (ijo,k1:k2) wind divergence (1/s) -!! trc real (ijo,k1:k2,ntrac) tracers -!! 1 = specific humidity (kg/kg) -!! 2 = Ozone mixing ratio (kg/kg) -!! 3 = cloud condensate mixing ratio (kg/kg) -!! . -!! . -!! atomic oxyge, oxygen etc -!! -!! iret integer return code -!! -!! Modules used: -!! sigio_r_module sigma file I/O -!! -!! Subprograms called: -!! sigio_rrdati read sigma single data field -!! sptez scalar spectral transform -!! sptezd gradient spectral transform -!! sptezm multiple scalar spectral transform -!! sptezmv multiple vector spectral transform -!! -!! Attributes: -!! Language: Fortran 90 -!! -!! -! Add Iredells subroutine to read sigma files -!------------------------------------------------------------------------------- +!> +!> @brief rtsig() reads and transforms sigma file. +!> +!> This subprogram reads a sigma file and transforms +!> the fields to a designated global grid. +!> Add Iredells subroutine to read sigma files. +!> +!> @param[out] lusig integer(sigio_intkind) sigma file unit number. +!> @param[out] head type(sigio_head) sigma file header. +!> @param[out] k1 integer first model level to return. +!> @param[out] k2 integer last model level to return. +!> @param[out] kgds integer (200) GDS to which to transform. +!> @param[out] ijo integer dimension of output fields. +!> @param[out] levs integer number of total vertical levels. +!> @param[out] ntrac integer number of output tracers. +!> @param[out] jcap integer number of waves. +!> @param[out] lnt2 integer (jcap+1)*(jcap+2). +!> @param[out] h real (ijo) surface orography (m). +!> @param[out] p real (ijo) surface pressure (Pa). +!> @param[out] px real (ijo) log surface pressure x-gradient (1/m). +!> @param[out] py real (ijo) log surface pressure y-gradient (1/m). +!> @param[out] t real (ijo,k1:k2) temperature (K). +!> @param[out] tx real (ijo,k1:k2) virtual temperature x-gradient (K/m). +!> @param[out] ty real (ijo,k1:k2) virtual temperature y-gradient (K/m). +!> @param[out] u real (ijo,k1:k2) x-component wind (m/s). +!> @param[out] v real (ijo,k1:k2) y-component wind (m/s). +!> @param[out] d real (ijo,k1:k2) wind divergence (1/s). +!> @param[out] trc real (ijo,k1:k2,ntrac) tracers. +!>
+!>                                   1 = specific humidity (kg/kg)
+!>                                   2 = Ozone mixing ratio (kg/kg)
+!>                                   3 = cloud condensate mixing ratio (kg/kg)
+!>                                   .
+!>                                   .
+!>                                       atomic oxyge, oxygen etc
+!>
+!>
+!> @param[out] iret Integer return code. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> 2013-04-19 | Jun Wang | Add option to get tmp and ps(in pascal) from enthalpy and ps(cb) option +!> 2013-05-06 | Shrinivas Moorthi | Initialize midea to 0 +!> 2013-05-07 | Shrinivas Moorthi | Remove mo3, mct, midea and define io3, ict etc correctly and get correct cloud condensate. +!> 2013-08-02 | Shrinivas Moorthi | Rewrote the whole routine to read the sigma file differently and to read all tracers. Added sptezj for two 2d fields +!> 2014-02-20 | Shrinivas Moorthi | Modified conversion from spectral to grid taking advantage of threding in SP library. This really speeds up the code. Also threaded loop for Temperature from Tv +!> +!> @author Mark Iredell np23 @date 1999-10-18 subroutine rtsig(lusig,head,k1,k2,kgds,ijo,levs,ntrac,jcap,lnt2,me, & h,p,px,py,t,u,v,d,trc,iret) @@ -248,43 +225,35 @@ subroutine rtsig(lusig,head,k1,k2,kgds,ijo,levs,ntrac,jcap,lnt2,me, & end subroutine ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!> modstuff() computes model coordinate dependent functions. +!> +!> This subprogram computes fields which depend on the model coordinate +!> such as pressure thickness and vertical velocity. +!> +!> @param[in] km integer number of levels. +!> @param[in] idvc integer vertical coordinate id (1 for sigma and 2 for hybrid). +!> @param[in] idsl integer type of sigma structure (1 for phillips or 2 for mean). +!> @param[in] nvcoord integer number of vertical coordinates. +!> @param[in] vcoord real (km+1,nvcoord) vertical coordinates. +!> @param[in] ps real surface pressure (Pa). +!> @param[in] psx real log surface pressure x-gradient (1/m). +!> @param[in] psy real log surface pressure y-gradient (1/m). +!> @param[in] d real (km) wind divergence (1/s). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[out] pi real (km+1) interface pressure (Pa). +!> @param[out] pm real (km) mid-layer pressure (Pa). +!> @param[out] om real (km) vertical velocity (Pa/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> 2013-04-19 | Jun Wang | Add option to get pi by using 8 byte real computation +!> +!> @author Mark Iredell np23 @date 1999-10-18 subroutine modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& pi,pm,om) -!$$$ Subprogram documentation block -! -! Subprogram: modstuff Compute model coordinate dependent functions -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram computes fields which depend on the model coordinate -! such as pressure thickness and vertical velocity. -! -! Program history log: -! 1999-10-18 Mark Iredell -! 2013-04-19 Jun Wang: add option to get pi by using 8byte real computation -! -! Usage: call modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& -! pd,pi,pm,os,om,px,py) -! Input argument list: -! km integer number of levels -! idvc integer vertical coordinate id (1 for sigma and 2 for hybrid) -! idsl integer type of sigma structure (1 for phillips or 2 for mean) -! nvcoord integer number of vertical coordinates -! vcoord real (km+1,nvcoord) vertical coordinates -! ps real surface pressure (Pa) -! psx real log surface pressure x-gradient (1/m) -! psy real log surface pressure y-gradient (1/m) -! d real (km) wind divergence (1/s) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! Output argument list: -! pi real (km+1) interface pressure (Pa) -! pm real (km) mid-layer pressure (Pa) -! om real (km) vertical velocity (Pa/s) -! -! Attributes: -! Language: Fortran 90 -! -!$$$ use sigio_module, only: sigio_modprd implicit none integer,intent(in):: km,idvc,idsl,nvcoord @@ -331,46 +300,38 @@ subroutine modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& end subroutine !------------------------------------------------------------------------------- +!> modstuff2() computes model coordinate dependent functions. +!> +!> This subprogram computes fields which depend on the model coordinate +!> such as pressure thickness and vertical velocity. +!> +!> @param[in] im integer inner computational domain. +!> @param[in] ix integer maximum inner dimension. +!> @param[in] km integer number of levels. +!> @param[in] idvc integer vertical coordinate id (1 for sigma and 2 for hybrid). +!> @param[in] idsl integer type of sigma structure (1 for phillips or 2 for mean). +!> @param[in] nvcoord integer number of vertical coordinates. +!> @param[in] vcoord real (km+1,nvcoord) vertical coordinates. +!> @param[in] ps real surface pressure (Pa). +!> @param[in] psx real log surface pressure x-gradient (1/m). +!> @param[in] psy real log surface pressure y-gradient (1/m). +!> @param[in] d real (km) wind divergence (1/s). +!> @param[in] u real (km) x-component wind (m/s). +!> @param[in] v real (km) y-component wind (m/s). +!> @param[out] pi real (km+1) interface pressure (Pa). +!> @param[out] pm real (km) mid-layer pressure (Pa). +!> @param[out] om real (km) vertical velocity (Pa/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> 2013-04-19 | Jun Wang | Add option to get pi by using 8 byte real computation +!> 2013-08-13 | Shrinivas Moorthi | Modified to include im points and thread +!> +!> @author Mark Iredell np23 @date 1999-10-18 subroutine modstuff2(im,ix,km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& pi,pm,om,me) -!$$$ Subprogram documentation block -! -! Subprogram: modstuff Compute model coordinate dependent functions -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram computes fields which depend on the model coordinate -! such as pressure thickness and vertical velocity. -! -! Program history log: -! 1999-10-18 Mark Iredell -! 2013-04-19 Jun Wang: add option to get pi by using 8byte real computation -! 2013-08-13 Shrinivas Moorthi - Modified to include im points and thread -! -! Usage: call modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& -! pd,pi,pm,os,om,px,py) -! Input argument list: -! im integer - inner computational domain -! ix integer - maximum inner dimension -! km integer number of levels -! idvc integer vertical coordinate id (1 for sigma and 2 for hybrid) -! idsl integer type of sigma structure (1 for phillips or 2 for mean) -! nvcoord integer number of vertical coordinates -! vcoord real (km+1,nvcoord) vertical coordinates -! ps real surface pressure (Pa) -! psx real log surface pressure x-gradient (1/m) -! psy real log surface pressure y-gradient (1/m) -! d real (km) wind divergence (1/s) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! Output argument list: -! pi real (km+1) interface pressure (Pa) -! pm real (km) mid-layer pressure (Pa) -! om real (km) vertical velocity (Pa/s) -! -! Attributes: -! Language: Fortran 90 -! -!$$$ use sigio_module, only : sigio_modprd implicit none integer, intent(in) :: im,ix,km,idvc,idsl,nvcoord,me @@ -443,61 +404,47 @@ subroutine modstuff2(im,ix,km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& end subroutine !----------------------------------------------------------------------- +!> trssc() transforms sigma spectral fields to grid. +!> +!> Transforms sigma spectral fields to grid and converts +!> log surface pressure to surface pressure and virtual temperature +!> to temperature. +!> +!> @param[in] jcap integer spectral truncation. +!> @param[in] nc integer first dimension (nc>=(jcap+1)*(jcap+2)). +!> @param[in] km integer number of levels. +!> @param[in] ntrac integer number of tracers. +!> @param[in] idvm integer mass variable id. +!> @param[in] idrt integer data representation type. +!> @param[in] lonb integer number of longitudes. +!> @param[in] latb integer number of latitudes. +!> @param[in] ijl integer horizontal dimension. +!> @param[in] j1 integer first latitude. +!> @param[in] j2 integer last latitude. +!> @param[in] jc integer number of cpus. +!> @param[in] szs real (nc) orography. +!> @param[in] sps real (nc) log surface pressure. +!> @param[in] st real (nc,levs) virtual temperature. +!> @param[in] sd real (nc,levs) divergence. +!> @param[in] sz real (nc,levs) vorticity. +!> @param[in] sq real (nc,levs*ntrac) tracers. +!> @param[out] zs real (ijl) orography. +!> @param[out] ps real (ijl) surface pressure. +!> @param[out] t real (ijl,km) temperature. +!> @param[out] u real (ijl,km) zonal wind. +!> @param[out] v real (ijl,km) meridional wind. +!> @param[out] q real (ijl,km*ntrac) tracers. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-10-18 | Mark Iredell | Initial +!> +!> @author Mark Iredell w/nmc23 @date 1992-10-31 subroutine trssc(jcap,nc,km,ntrac,idvc,idvm,idsl,nvcoord,vcoord, & cpi,idrt,lonb,latb,ijl,ijn,j1,j2,jc,chgq0, & szs,sps,st,sd,sz,sq,gfszs,gfsps,gfsp,gfsdp, & gfst,gfsu,gfsv,gfsq,gfsw) -!$$$ subprogram documentation block -! -! subprogram: trssc transform sigma spectral fields to grid -! prgmmr: iredell org: w/nmc23 date: 92-10-31 -! -! abstract: transforms sigma spectral fields to grid and converts -! log surface pressure to surface pressure and virtual temperature -! to temperature. -! -! program history log: -! 91-10-31 mark iredell -! -! usage: call trssc(jcap,nc,km,ntrac,idvm, -! & idrt,lonb,latb,ijl,j1,j2,jc, -! & szs,sps,st,sd,sz,sq,zs,ps,t,u,v,q) -! input argument list: -! jcap integer spectral truncation -! nc integer first dimension (nc>=(jcap+1)*(jcap+2)) -! km integer number of levels -! ntrac integer number of tracers -! idvm integer mass variable id -! idrt integer data representation type -! lonb integer number of longitudes -! latb integer number of latitudes -! ijl integer horizontal dimension -! j1 integer first latitude -! j2 integer last latitude -! jc integer number of cpus -! szs real (nc) orography -! sps real (nc) log surface pressure -! st real (nc,levs) virtual temperature -! sd real (nc,levs) divergence -! sz real (nc,levs) vorticity -! sq real (nc,levs*ntrac) tracers -! output argument list: -! zs real (ijl) orography -! ps real (ijl) surface pressure -! t real (ijl,km) temperature -! u real (ijl,km) zonal wind -! v real (ijl,km) meridional wind -! q real (ijl,km*ntrac) tracers -! -! subprograms called: -! sptran perform a scalar spherical transform -! -! attributes: -! language: fortran -! -!c$$$ -!! use gfsio_module -! use gfsio_rst implicit none integer,intent(in)::jcap,nc,km,ntrac,idvc,idvm,idsl,nvcoord,idrt,lonb,latb integer,intent(in)::ijl,ijn,j1,j2,jc,chgq0 diff --git a/sorc/ncep_post.fd/GPVS.f b/sorc/ncep_post.fd/GPVS.f index c60dd2f6d..3e91b7d3d 100644 --- a/sorc/ncep_post.fd/GPVS.f +++ b/sorc/ncep_post.fd/GPVS.f @@ -1,36 +1,24 @@ !> @file -! . . . -!> SUBPROGRAM: GPVS COMPUTE SATURATION VAPOR PRESSURE TABLE -!! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82 -!! -!! ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE TABLE AS A FUNCTION OF -!! TEMPERATURE FOR THE TABLE LOOKUP FUNCTION FPVS. -!! EXACT SATURATION VAPOR PRESSURES ARE CALCULATED IN SUBPROGRAM FPVSX. -!! THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A LENGTH -!! OF 7501 FOR TEMPERATURES RANGING FROM 180.0 TO 330.0 KELVIN. -!! -!! PROGRAM HISTORY LOG: -!! 91-05-07 IREDELL -!! 94-12-30 IREDELL EXPAND TABLE -!! 96-02-19 HONG ICE EFFECT -!! -!! USAGE: CALL GPVS -!! -!! SUBPROGRAMS CALLED: -!! (FPVSX) - INLINABLE FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE -!! -!! COMMON BLOCKS: -!! COMPVS - SCALING PARAMETERS AND TABLE FOR FUNCTION FPVS. -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE: IBM SP -!! -!! -!####################################################################### -!-- Lookup tables for the saturation vapor pressure w/r/t water & ice -- -!####################################################################### -! +!> @brief gpvs() computes saturation vapor pressure table. +!> +!> Compute saturation vapor pressure table as a function of +!> temperature for the table lookup function FPVS. +!> Exact saturation vapor pressures are calculated in subprogram FPVSX. +!> The current implementation computes a table with a length +!> of 7501 for temperatures ranging from 180.0 to 330.0 Kelvin. +!> +!> @param[out] pvu real (km) potential vorticity (10**-6*K*m**2/kg/s). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1982-12-30 | N Phillips | Initial +!> 1991-05-07 | Mark Iredell | Made into inlinable function +!> 1994-12-30 | Mark Iredell | Expand table +!> 1996-02-19 | Hong | Ice effect +!> +!> @note Lookup tables for the saturation vapor pressure w/r/t water & ice. +!> @author N Phillips W/NP2 @date 1982-12-30 SUBROUTINE GPVS ! ****************************************************************** @@ -65,40 +53,28 @@ SUBROUTINE GPVS !----------------------------------------------------------------------- FUNCTION FPVS(T) !----------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: FPVS COMPUTE SATURATION VAPOR PRESSURE -! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82 -! -! ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE FROM THE TEMPERATURE. -! A LINEAR INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE -! COMPUTED IN GPVS. SEE DOCUMENTATION FOR FPVSX FOR DETAILS. -! INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. -! THE INTERPOLATION ACCURACY IS ALMOST 6 DECIMAL PLACES. -! ON THE CRAY, FPVS IS ABOUT 4 TIMES FASTER THAN EXACT CALCULATION. -! THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. -! -! PROGRAM HISTORY LOG: -! 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION -! 94-12-30 IREDELL EXPAND TABLE -! 96-02-19 HONG ICE EFFECT -! -! USAGE: PVS=FPVS(T) -! -! INPUT ARGUMENT LIST: -! T - REAL TEMPERATURE IN KELVIN -! -! OUTPUT ARGUMENT LIST: -! FPVS - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) -! -! COMMON BLOCKS: -! COMPVS - SCALING PARAMETERS AND TABLE COMPUTED IN GPVS. -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: IBM SP -! -!$$$ +!> fpvs() computes saturation vapor pressure. +!> +!> Compute saturation vapor pressure from the temperature. +!> A linear interpolation is done between values in a lookup table +!> computed in GPVS. See documentation for FPVSX for details. +!> Input values outside table range are reset to table extrema. +!> The interpolation accuracy is almost 6 decimal places. +!> On the CRAY, FPVS is about 4 times faster than exact calculation. +!> This function should be expanded inline in the calling routine. +!> +!> @param[in] T real temperature in Kelvin. +!> @param[out] FPVS real saturation vapor pressure in kilopascals (CB). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1982-12-30 | N Phillips | Initial +!> 1991-05-07 | Mark Iredell | Made into inlinable function +!> 1994-12-30 | Mark Iredell | Expand table +!> 1996-02-19 | Hong | Ice effect +!> +!> @author N Phillips W/NP2 @date 1982-12-30 !----------------------------------------------------------------------- use svptbl_mod, only : NX,C1XPVS,C2XPVS,TBPVS ! @@ -144,41 +120,33 @@ FUNCTION FPVS0(T,NX,C1XPVS0,C2XPVS0,TBPVS0) !----------------------------------------------------------------------- FUNCTION FPVSX(T) !----------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: FPVSX COMPUTE SATURATION VAPOR PRESSURE -! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82 -! -! ABSTRACT: EXACTLY COMPUTE SATURATION VAPOR PRESSURE FROM TEMPERATURE. -! THE WATER MODEL ASSUMES A PERFECT GAS, CONSTANT SPECIFIC HEATS -! FOR GAS AND LIQUID, AND NEGLECTS THE VOLUME OF THE LIQUID. -! THE MODEL DOES ACCOUNT FOR THE VARIATION OF THE LATENT HEAT -! OF CONDENSATION WITH TEMPERATURE. THE ICE OPTION IS NOT INCLUDED. -! THE CLAUSIUS-CLAPEYRON EQUATION IS INTEGRATED FROM THE TRIPLE POINT -! TO GET THE FORMULA -! PVS=PSATK*(TR**XA)*EXP(XB*(1.-TR)) -! WHERE TR IS TTP/T AND OTHER VALUES ARE PHYSICAL CONSTANTS -! THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. -! -! PROGRAM HISTORY LOG: -! 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION -! 94-12-30 IREDELL EXACT COMPUTATION -! 96-02-19 HONG ICE EFFECT -! -! USAGE: PVS=FPVSX(T) -! REFERENCE: EMANUEL(1994),116-117 -! -! INPUT ARGUMENT LIST: -! T - REAL TEMPERATURE IN KELVIN -! -! OUTPUT ARGUMENT LIST: -! FPVSX - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: IBM SP -! -!$$$ +!> fpvsx() computes saturation vapor pressure. +!> +!> Exactly compute saturation vapor pressure from temperature. +!> The water model assumes a perfect gas, constant specific heats +!> for gas and liquid, and neglects the volume of the liquid. +!> The model does account for the variation of the latent heat +!> of condensation with temperature. The ice option is not included. +!> The Clausius-Clapeyron equation is integrated from the triple point +!> To get the formula +!> @code +!> PVS=PSATK*(TR**XA)*exp(XB*(1.-TR)) +!> @endcode +!> where TR is TTP/T and other values are physical constants +!> This function should be expanded inline in the calling routine. +!> +!> @param[in] T real temperature in Kelvin. +!> @param[out] FPVSX real saturation vapor pressure in kilopascals (CB). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1982-12-30 | N Phillips | Initial +!> 1991-05-07 | Mark Iredell | Made into inlinable function +!> 1994-12-30 | Mark Iredell | Exact computation +!> 1996-02-19 | Hong | Ice effect +!> +!> @author N Phillips W/NP2 @date 1982-12-30 !----------------------------------------------------------------------- implicit none ! diff --git a/sorc/ncep_post.fd/ICAOHEIGHT.f b/sorc/ncep_post.fd/ICAOHEIGHT.f index f21dc427b..139f99307 100644 --- a/sorc/ncep_post.fd/ICAOHEIGHT.f +++ b/sorc/ncep_post.fd/ICAOHEIGHT.f @@ -18,15 +18,15 @@ SUBROUTINE ICAOHEIGHT(MAXWP, & !input ! Language: Fortran 90 ! Software Standards: UMDP3 v6 -use ctlblk_mod, only: jsta, jend, spval, im +use ctlblk_mod, only: jsta, jend, spval, im, ista, iend use physcons_post, only: con_g, con_rd IMPLICIT None ! Subroutine Arguments: !REAL, INTENT(IN) :: SPVAL -REAL, INTENT(IN) :: MAXWP(IM,jsta:jend) !P field for conversion +REAL, INTENT(IN) :: MAXWP(ista:iend,jsta:jend) !P field for conversion -REAL, INTENT(INOUT) :: MAXWICAOZ(IM,jsta:jend) !ICAO height in m +REAL, INTENT(INOUT) :: MAXWICAOZ(ista:iend,jsta:jend) !ICAO height in m !INTEGER, INTENT(INOUT) :: ErrorStatus ! Local Constants: @@ -62,7 +62,7 @@ SUBROUTINE ICAOHEIGHT(MAXWP, & !input DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND pressure = MAXWP(i,j) IF ( (pressure <= 1000.) .AND. (pressure >= 0.) ) THEN pressure = 1000. diff --git a/sorc/ncep_post.fd/INITPOST.F b/sorc/ncep_post.fd/INITPOST.F index 87cd31af5..5e74564ab 100644 --- a/sorc/ncep_post.fd/INITPOST.F +++ b/sorc/ncep_post.fd/INITPOST.F @@ -1,46 +1,26 @@ !> @file -! -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: RUSS TREADON ORG: W/NP2 DATE: 93-11-10 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN ETA MODEL OR POST -!! PROCESSOR RUN. -!! -!! THIS ROUTINE ASSUMES THAT INTEGERS AND REALS ARE THE SAME SIZE -!! -!! PROGRAM HISTORY LOG: -!! 93-11-10 RUSS TREADON - ADDED DOCBLOC -!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D -!! 99-01 20 TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! 02-08-15 H CHUANG - UNIT CORRECTION AND GENERALIZE PROJECTION OPTIONS -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief initpost() initializes post for run. +!> +!> @author Russ Treadon W/NP2 @date 1993-11-10 + +!> This routine initializes constants and +!> variables at the start of an ETA model or post +!> processor run. +!> +!> This routine assumes that integers and reals are the same size. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-11-10 | Russ Treadon | Initial. Added DOCBLOC +!> 1998-05-29 | T Black | Conversion from 1-D to 2-D +!> 1999-01-20 | Jim Tuccillo | MPI Version +!> 2001-10-25 | H CHuang | Modified to process hybrid model output +!> 2002-06-19 | Mike Baldwin | WRF Version +!> 2002-08-15 | H CHuang | Unit correction and generalize projection options +!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend) +!> +!> @author Russ Treadon W/NP2 @date 1993-11-10 SUBROUTINE INITPOST use vrbls4d, only: dust, smoke diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f deleted file mode 100644 index 2f04cfb7e..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS.f +++ /dev/null @@ -1,3264 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2007-03-01 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2011-02-07 Jun Wang add grib2 option -!! 2011-12-14 Sarah Lu add aer option -!! 2012-01-07 Sarah Lu compute air density -!! 2012-12-22 Sarah Lu add aerosol zerout option -!! 2015-03-16 S. Moorthi adding gocart_on option -!! 2015-03-18 S. Moorthi Optimization including threading -!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D, & - iostatusAER,nfile,ffile,rfile) -! SUBROUTINE INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - - - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa, & - u10h,v10h - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice -! use kinds, only: i_llong - use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_getheadvar, nemsio_close - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat - use upp_physics, only: fpvsnew -! use wrf_io_flags_mod, only: ! Do we need this? -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - type(nemsio_gfile),intent(inout) :: nfile,ffile,rfile -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - integer,intent(in) :: NREC,iostatusFlux,iostatusD3D,iostatusAER - character(len=20) :: VarName, VcoordName - integer :: Status - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL - logical, parameter :: debugprint = .false., zerout = .false. -! logical, parameter :: debugprint = .true., zerout = .false. - CHARACTER*32 LABEL - CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200),IGDS(18) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour - integer nfhour ! forecast hour from nems io file - REAL RINC(5) - - REAL DUMMY(IM,JM), DUMMY2(IM,JM) - real, allocatable :: fi(:,:,:) -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - impf,jmpf,nframed2,iunitd3d,ierr,idum,iret - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv - - character*8, allocatable :: recname(:) - character*16,allocatable :: reclevtyp(:) - integer, allocatable :: reclev(:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - - real buf(im,jsta_2l:jend_2u) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT, isa, jsa -! REAL, PARAMETER :: QMIN = 1.E-15 - -! DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NEMS' - WRITE(6,*)'me=',me,'LMV=',size(LMV,1),size(LMV,2),'LMH=', & - size(LMH,1),size(LMH,2),'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo -! -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do -! -! how do I get the filename? -! fileName = '/ptmp/wx20mb/wrfout_01_030500' -! DateStr = '2002-03-05_18:00:00' -! how do I get the filename? -! call ext_int_ioinit(SysDepInfo,Status) -! print*,'called ioinit', Status -! call ext_int_open_for_read( trim(fileName), 0, 0, " ", -! & DataHandle, Status) -! print*,'called open for read', Status -! if ( Status /= 0 ) then -! print*,'error opening ',fileName, ' Status = ', Status ; stop -! endif -! get date/time info -! this routine will get the next time from the file, not using it -! print *,'DateStr before calling ext_int_get_next_time=',DateStr -! call ext_int_get_next_time(DataHandle, DateStr, Status) -! print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle - -! The end j row is going to be jend_2u for all variables except for V. - - JS = JSTA_2L - JE = JEND_2U - -! get start date - if (me == 0)then - print*,'nrec=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(im*jm),glon1d(im*jm)) - allocate(vcoord4(lm+1,3,2)) - call nemsio_getfilehead(nfile,iret=iret & - ,idate=idate(1:7),nfhour=nfhour,recname=recname & - ,reclevtyp=reclevtyp,reclev=reclev,lat=glat1d & - ,lon=glon1d,nframe=nframe,vcoord=vcoord4) - if(iret/=0)print*,'error getting idate,nfhour' - print *,'latstar1=',glat1d(1),glat1d(im*jm) -! print *,'printing an inventory of GFS nemsio file' -! do i=1,nrec -! print *,'recname=',(trim(recname(i))) -! print *,'reclevtyp=',(trim(reclevtyp(i))) -! print *,'reclev=',(reclev(i)) -! end do -! deallocate (recname,reclevtyp,reclev) - -! call nemsio_getfilehead(ffile,nrec=idum) -! print*,'nrec for flux file = ',idum -! allocate(recname(idum),reclevtyp(idum),reclev(idum)) -! call nemsio_getfilehead(ffile,iret=iret, & -! recname=recname,reclevtyp=reclevtyp,reclev=reclev) -! do i=1,idum -! print *,'recname=',(trim(recname(i))) -! print *,'reclevtyp=',(trim(reclevtyp(i))) -! print *,'reclev=',(reclev(i)) -! end do - -!$omp parallel do private(i,j) - do j=1,jm - do i=1,im - dummy(i,j) = glat1d((j-1)*im+i) - dummy2(i,j) = glon1d((j-1)*im+i) - end do - end do -! - if (hyb_sigp) then - do l=1,lm+1 - ak5(l) = vcoord4(l,1,1) - bk5(l) = vcoord4(l,2,1) - enddo - endif -! - deallocate(recname,reclevtyp,reclev,glat1d,glon1d,vcoord4) -! can't get idate and fhour, specify them for now -! idate(4)=2006 -! idate(2)=9 -! idate(3)=16 -! idate(1)=0 -! fhour=6.0 - print*,'idate before broadcast = ',(idate(i),i=1,7) - end if - call mpi_bcast(idate(1), 7, MPI_INTEGER, 0, mpi_comm_comp, iret) - call mpi_bcast(nfhour, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) - call mpi_bcast(nframe, 1, MPI_INTEGER, 0, mpi_comm_comp, iret) - print*,'idate after broadcast = ',(idate(i),i=1,4) - print*,'nfhour = ',nfhour - - if (hyb_sigp) then - call mpi_bcast(ak5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) - call mpi_bcast(bk5, lm+1, MPI_REAL, 0, mpi_comm_comp, iret) - endif - if (me == 0) print *,' ak5=',ak5 - if (me == 0) print *,' bk5=',bk5 - -! sample print point - ii = im/2 - jj = jm/2 - call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ,gdlat(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ,gdlon(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,ierr) - - print *,'before call EXCH,mype=',me,'max(gdlat)=',maxval(gdlat), & - 'max(gdlon)=', maxval(gdlon) - CALL EXCH(gdlat(1,JSTA_2L)) - print *,'after call EXCH,mype=',me - -!$omp parallel do private(i,j) - do j = jsta, jend_m - do i = 1, im-1 - DX (i,j) = ERAD*COS(GDLAT(I,J)*DTR) *(GDLON(I+1,J)-GDLON(I,J))*DTR - DY (i,j) = ERAD*(GDLAT(I,J)-GDLAT(I,J+1))*DTR ! like A*DPH -! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) -! if (i == ii .and. j == jj) print*,'sample LATLON, DY, DY=' & -! ,i,j,GDLAT(I,J),GDLON(I,J),DX(I,J),DY(I,J) - end do - end do - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - F(I,J) = 1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi) - end do - end do - - impf = im - jmpf = jm - print*,'impf,jmpf,nframe= ',impf,jmpf,nframe - -!MEB not sure how to get these - ! waiting to read in lat lon from GFS soon -! varname='GLAT' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! GDLAT=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,buf,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! GDLAT=SPVAL -! else -! do j = jsta_2l, jend_2u -! do i = 1, im -! F(I,J)=1.454441e-4*sin(buf(I,J)) ! 2*omeg*sin(phi) -! GDLAT(I,J)=buf(I,J)*RTD - -! enddo -! enddo -! end if -! end if - -! varname='GLON' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! GDLON=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,buf,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! GDLON=SPVAL -! else -! do j = jsta_2l, jend_2u -! do i = 1, im -! GDLON(I,J)=buf(I,J)*RTD -! if(i == 409.and.j == 835)print*,'GDLAT GDLON in INITPOST=' -! + ,i,j,GDLAT(I,J),GDLON(I,J) -! enddo -! enddo -! end if -! end if - -! if(jsta<=594.and.jend>=594)print*,'gdlon(120,594)= ', -! + gdlon(120,594) - - -! iyear=idate(4)+2000 ! older gfsio only has 2 digit year - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! - print *,' idate=',idate - print *,' jdate=',jdate -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - print *,' rinc=',rinc - ifhr = nint(rinc(2)+rinc(1)*24.) - print *,' ifhr=',ifhr - ifmin = nint(rinc(3)) -! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! GFS has the same accumulation bucket for precipitation and fluxes and it is written to header -! the header has the start hour information so post uses it to recontruct bucket - if(me==0)then - call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) - if(iret==0)then - tprec = 1.0*ifhr-zhour - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec from flux file header= ',tprec - else - print*,'Error reading accumulation bucket from flux file', & - 'header - will try to read from env variable FHZER' - CALL GETENV('FHZER',ENVAR) - read(ENVAR, '(I2)')idum - tprec = idum*1.0 - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'TPREC from FHZER= ',tprec - end if - end if - - call mpi_bcast(tprec, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tclod, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdlw, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(trdsw, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tsrfc, 1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(tmaxmin,1,MPI_REAL,0,mpi_comm_comp,iret) - call mpi_bcast(td3d, 1,MPI_REAL,0,mpi_comm_comp,iret) - -! Getting tstart - tstart=0. -! VarName='TSTART' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file" -! else -! call mpi_file_read_at(iunit,file_offset(index)+5*4 -! + ,garb,1,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName," using MPIIO" -! else -! print*,VarName, ' from MPIIO READ= ',garb -! tstart=garb -! end if -! end if - print*,'tstart= ',tstart - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default -! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp -! + ,1,ioutcount,istatus) - -! IF(itmp < 1)THEN -! RESTRT=.FALSE. -! ELSE -! RESTRT=.TRUE. -! END IF - -! print*,'status for getting RESTARTBIN= ',istatus - -! print*,'Is this a restrt run? ',RESTRT - - IF(tstart > 1.0E-2)THEN - ifhr = ifhr+NINT(tstart) - rinc = 0 - idate = 0 - rinc(2) = -1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1) = idate(2) - SDAT(2) = idate(3) - SDAT(3) = idate(1) - IHRST = idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - imp_physics = 99 !set GFS mp physics to 99 for Zhao scheme - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) - if (iret /= 0) then - print*,VarName,' not found in file-Assigned 2 for UMD as default' - IVEGSRC=1 - end if - end if - call mpi_bcast(IVEGSRC,1,MPI_INTEGER,0,mpi_comm_comp,iret) - print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - print*,'novegtype= ',novegtype - - VarName='CU_PHYSICS' - if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 4 for SAS as default" - iCU_PHYSICS=4 - end if - end if - call mpi_bcast(iCU_PHYSICS,1,MPI_INTEGER,0,mpi_comm_comp,iret) - if (me == 0) print*,'CU_PHYSICS= ',iCU_PHYSICS -! waiting to retrieve lat lon infor from raw GFS output -! VarName='DX' - -! VarName='DY' - -! GFS does not need DT to compute accumulated fields, set it to one -! VarName='DT' - DT=1 -! GFS does not need truelat -! VarName='TRUELAT1' - -! VarName='TRUELAT2' - -! Specigy maptype=4 for Gaussian grid -! maptype=4 -! write(6,*) 'maptype is ', maptype -! HBM2 is most likely not in Grib message, set them to ones - HBM2=1.0 - -! try to get kgds from flux grib file and then convert to igds that is used by GRIBIT.f -! flux files are now nemsio files so comment the following lines out -! if(me == 0)then -! jpds=-1.0 -! jgds=-1.0 -! igds=0 -! call getgb(iunit,0,im_jm,0,jpds,jgds,kf & -! ,k,kpds,kgds,lb,dummy,ierr) -! if(ierr == 0)then -! call R63W72(KPDS,KGDS,JPDS,IGDS(1:18)) -! print*,'in INITPOST_GFS,IGDS for GFS= ',(IGDS(I),I=1,18) -! end if -! end if -! call mpi_bcast(igds(1),18,MPI_INTEGER,0,mpi_comm_comp,iret) -! print*,'IGDS for GFS= ',(IGDS(I),I=1,18) - -! Specigy grid type -! if(iostatusFlux==0)then - if(IGDS(4)/=0)then - maptype=IGDS(3) - else if((im/2+1)==jm)then - maptype=0 !latlon grid - else - maptype=4 ! default gaussian grid - end if - gridtype='A' - - if (me == 0) write(6,*) 'maptype and gridtype is ', maptype,gridtype - -! start retrieving data using gfsio, first land/sea mask - -! VarName='land' -! VcoordName='sfc' -! l=1 - -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! -! do j = 1, jm -! do i = 1, im -! dummy(I,J)=1.0 - dummy(I,J) ! convert Grib message to 2D -! if (j == jm/2 .and. mod(i,10) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! -! enddo -! enddo -! end if -! end if -! -! call mpi_scatterv(dummy,icnt,idsp,mpi_real -! + ,sm(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - - VcoordName='sfc' ! surface fileds - l=1 - -! start retrieving data using getgb, first land/sea mask - VarName='land' - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,impf,jmpf,nframe,sm) - -! where(sm /= spval)sm=1.0-sm ! convert to sea mask -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',sm(isa,jsa) - - -! sea ice mask using getgb - - VarName='icec' - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sice) - -! if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, these -! points have sea ice changed to zero, i.e., trust land mask more than sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - -! Terrain height * G using nemsio - VarName='hgt' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,fis) - -! where(fis /= spval)fis=fis*grav - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (fis(i,j) /= spval) then - zint(i,j,lp1) = fis(i,j) - fis(i,j) = fis(i,j) * grav - - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',fis(isa,jsa) - -! Surface pressure using nemsio - VarName='pres' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pint(1,jsta_2l,lp1)) - -! if(debugprint)print*,'sample surface pressure = ',pint(isa,jsa,lp1 - -! -! vertical loop for Layer 3d fields -! -------------------------------- - VcoordName = 'mid layer' - - do l=1,lm - ll=lm-l+1 - -! model level T - print*,'start retrieving GFS T using nemsio' - VarName='tmp' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,t(1,jsta_2l,ll)) - -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,t(isa,jsa,ll) - -! model level q - VarName='spfh' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,q(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,q(isa,jsa,ll) - -! i model level u - VarName='ugrd' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,uh(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,uh(isa,jsa,ll) - -! model level v - VarName='vgrd' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,vh(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,vh(isa,jsa,ll) - -! model level pressure - if (.not. hyb_sigp) then - VarName='pres' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pmid(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) - -! GFS is on A grid and does not need PMIDV - -! dp - VarName='dpres' -! write(0,*)' bef getnemsandscatter ll=',ll,' l=',l,VarName - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dpres(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll) - endif -! ozone mixing ratio - VarName='o3mr' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,o3(1,jsta_2l,ll)) - -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) -! write(1000+me,*)'sample ',ll,VarName,' = ',ll,o3(isa,jsa,ll) - -! cloud water and ice mixing ratio for zhao scheme -! need to look up old eta post to derive cloud water/ice from cwm -! Zhao scheme does not produce suspended rain and snow - -!$omp parallel do private(i,j) - do j = jsta, jend - do i=1,im - qqw(i,j,ll) = 0. - qqr(i,j,ll) = 0. - qqs(i,j,ll) = 0. - qqi(i,j,ll) = 0. - enddo - enddo - - VarName='clwmr' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cwm(1,jsta_2l,ll)) -! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,cwm(isa,jsa,ll) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(t(i,j,ll) < (TFRZ-15.) )then ! dividing cloud water from ice - qqi(i,j,ll) = cwm(i,j,ll) - else - qqw(i,j,ll) = cwm(i,j,ll) - end if -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',trim(VarName), ' after scatter= ' -! + ,i,j,ll,cwm(i,j,ll) - end do - end do -! if (iret /= 0)print*,'Error scattering array';stop - -! pressure vertical velocity - VarName='vvel' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,omga(1,jsta_2l,ll)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,omga(isa,jsa,ll) - -! With SHOC NEMS/GSM does output TKE now - VarName='tke' - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,q2(1,jsta_2l,ll)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,q2(isa,jsa,ll) - - - end do ! do loop for l - -! construct interface pressure from model top (which is zero) and dp from top down PDTOP -! pdtop = spval - pt = 0. -! pd = spval ! GFS does not output PD - - ii = im/2 - jj = (jsta+jend)/2 - -!!!!! COMPUTE Z, GFS integrates Z on mid-layer instead -!!! use GFS contants to see if height becomes more aggreable to GFS pressure grib file - if (hyb_sigp) then - do l=lm,1,-1 -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - Moorthi - enddo - enddo - if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) - enddo - else - do l=2,lm -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo - if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) - end do - endif - - allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) - allocate(fi(im,jsta:jend,2)) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - pd(i,j) = spval ! GFS does not output PD - pint(i,j,1) = PT - alpint(i,j,lp1) = log(pint(i,j,lp1)) - wrk1(i,j) = log(PMID(I,J,LM)) - wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) - FI(I,J,1) = FIS(I,J) & - + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) - ZMID(I,J,LM) = FI(I,J,1) * gravi - end do - end do - - print *,' Tprof=',t(ii,jj,:) - print *,' Qprof=',q(ii,jj,:) - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer - - DO L=LM,2,-1 ! omit computing model top height because it's infinity - ll = l - 1 -! write(0,*)' me=',me,'ll=',ll,' gravi=',gravi,rgas,' fv=',fv -!$omp parallel do private(i,j,tvll,pmll,fact) - do j = jsta, jend -! write(0,*)' j=',j,' me=',me - do i = 1, im - alpint(i,j,l) = log(pint(i,j,l)) - tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) - pmll = log(PMID(I,J,LL)) - -! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,' tvll =', tvll, & -! ' pmll=',pmll,' wrk2=',wrk2(i,j),' wrk1=',wrk1(i,j),' fi1=',fi(i,j,1), & -! ' T=',T(i,j,LL),' Q=',Q(i,j,ll) - - FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & - * (wrk1(i,j)-pmll) - ZMID(I,J,LL) = FI(I,J,2) * gravi -! - FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) - ZINT(I,J,L) = ZMID(I,J,L) + (ZMID(I,J,LL)-ZMID(I,J,L)) * FACT - FI(I,J,1) = FI(I,J,2) - wrk1(i,J) = pmll - wrk2(i,j) = tvll -! if (me == 0 .and. i == ii .and. j == jj ) print*,'L ZINT= ',l,zint(ii,jj,l), & -! 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & -! LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - ENDDO - - if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), & - 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)),'pmid(l-1)=', & - LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L),'zmid(l-1)=',ZMID(Ii,Jj,L-1) - ENDDO - deallocate(wrk1,wrk2,fi) - - - if (gocart_on) then - -! GFS output dust in nemsio (GOCART) - do n=1,nbin_du - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - dust(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! DUST = SPVAL - VarName='du001' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,1) - end do ! do loop for l - - VarName='du002' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,2) - end do ! do loop for l - - VarName='du003' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,3)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,3) - end do ! do loop for l - - VarName='du004' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,4)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,4) - end do ! do loop for l - - VarName='du005' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dust(1,jsta_2l,ll,5)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5) - end do ! do loop for l -! -! GFS output sea salt in nemsio (GOCART) - do n=1,nbin_ss - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - salt(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SALT = SPVAL - VarName='ss001' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,1) - end do ! do loop for l - - VarName='ss002' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,2) - end do ! do loop for l - - VarName='ss003' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,3)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3) - end do ! do loop for l - - VarName='ss004' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,4)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,4) - end do ! do loop for l - - VarName='ss005' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,salt(1,jsta_2l,ll,5)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5) - end do ! do loop for l - -! GFS output black carbon in nemsio (GOCART) - do n=1,nbin_oc - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - soot(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SOOT = SPVAL - VarName='bcphobic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,soot(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,1) - end do ! do loop for l - - VarName='bcphilic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,soot(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,2) - end do ! do loop for l - -! GFS output organic carbon in nemsio (GOCART) - do n=1,nbin_oc - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - waso(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! WASO = SPVAL - VarName='ocphobic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,waso(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,1) - end do ! do loop for l - - VarName='ocphilic' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,waso(1,jsta_2l,ll,2)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,2) - end do ! do loop for l - -! GFS output sulfate in nemsio (GOCART) - do n=1,nbin_su - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - suso(i,j,l,n) = spval - enddo - enddo - enddo - enddo -! SUSO = SPVAL - VarName='so4' - VcoordName='mid layer' - do l=1,lm - ll=lm-l+1 - call getnemsandscatter(me,nfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,suso(1,jsta_2l,ll,1)) -! if(debugprint)print*,'sample l ',VarName,' = ',ll,suso(isa,jsa,ll,1) - end do ! do loop for l - - -! -- compute air density RHOMID and remove negative tracer values - do l=1,lm -!$omp parallel do private(i,j,n,tv) - do j=jsta,jend - do i=1,im - - TV = T(I,J,L) * (H1+D608*MAX(Q(I,J,L),QMIN)) - RHOMID(I,J,L) = PMID(I,J,L) / (RD*TV) - do n = 1, NBIN_DU - IF ( dust(i,j,l,n) < SPVAL) THEN - DUST(i,j,l,n) = MAX(DUST(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_SS - IF ( salt(i,j,l,n) < SPVAL) THEN - SALT(i,j,l,n) = MAX(SALT(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_OC - IF ( waso(i,j,l,n) < SPVAL) THEN - WASO(i,j,l,n) = MAX(WASO(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_BC - IF ( soot(i,j,l,n) < SPVAL) THEN - SOOT(i,j,l,n) = MAX(SOOT(i,j,l,n), 0.0) - ENDIF - enddo - do n = 1, NBIN_SU - IF ( suso(i,j,l,n) < SPVAL) THEN - SUSO(i,j,l,n) = MAX(SUSO(i,j,l,n), 0.0) - ENDIF - enddo - - end do - end do - end do - endif ! endif for gocart_on -! - -! PBL height using nemsio - VarName='hpbl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pblh) -! if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! surface potential T using getgb - VarName='tmp' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway - NPHS=2. - DT=80. - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT -! All GFS time-averaged quantities are in 6 hour bucket -! TPREC=6.0 - -! convective precip in m per physics time step using gfsio -! VarName='cprat' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! do j = 1, jm -! do i = 1, im -! dummy(I,J)= dummy(i,j)*dtq2/1000. ! convert to m -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! enddo -! enddo -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , avgcprate(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! convective precip in m per physics time step using getgb - VarName='cprat' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - cprate(i,j) = avgcprate(i,j) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prate' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgprec) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec(i,j) /= spval) avgprec(i,j) = avgprec(i,j) * (dtq2*0.001) - enddo - enddo - -! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - - prec=avgprec !set avg cprate to inst one to derive other fields - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - - -! inst snow water eqivalent using nemsio - VarName='weasd' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sno) -! if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! snow depth in mm using nemsio - VarName='snod' -! VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,si) -! where(si /= spval)si=si*1000. ! convert to mm -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -!!$omp parallel do private(i,j,l) -! do l=1,lm -! do j=jsta,jend -! do i=1,im -! Q2(i,j,l) = SPVAL ! GFS does not have TKE because it uses MRF scheme -! ! GFS does not have surface exchange coeff -! enddo -! enddo -! enddo - -! 2m T using nemsio - VarName='tmp' - VcoordName='2 m above gnd' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,tshltr) -! if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using gfsio -! VarName='spfh' -! VcoordName='2m above gnc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,qshltr(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! 2m specific humidity using nemsio - VarName='spfh' - VcoordName='2 m above gnd' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,qshltr) -! if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - - -! mid day avg albedo in fraction using gfsio -! VarName='albdo' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! else -! do j = 1, jm -! do i = 1, im -! dummy(I,J)= dummy(i,j)/100. ! convert to fraction -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample ',VarName, ' = ',i,j,dummy(i,j) -! enddo -! enddo -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + ,avgalbedo(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! mid day avg albedo in fraction using nemsio - VarName='albdo' - VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgalbedo) -! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc' - VcoordName='atmos col' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='mxsalb' - VcoordName='sfc' -! l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - radot(i,j) = spval ! GFS does not have inst surface outgoing longwave - enddo - enddo - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! will retrive f_ice when GFS switches to Ferrier scheme -! varname='F_ICE' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_ice=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_ice=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_ice( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_ice= ', -! + i,j,l,F_ice( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! varname='F_RAIN' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_rain=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_rain=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_rain( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*,'sample F_rain= ', -! + i,j,l,F_rain( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! varname='F_RIMEF' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! F_RimeF=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im*lm -! this_length=im*(jend_2u-jsta_2l+1)*lm -! call mpi_file_read_at(iunit,this_offset -! + ,buf3d,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! F_RimeF=SPVAL -! else -! do l = 1, lm -! ll=lm-l+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! F_RimeF( i, j, l ) = buf3d ( i, ll, j ) -! if(i == im/2.and.j == (jsta+jend)/2)print*, -! + 'sample F_RimeF= ',i,j,l,F_RimeF( i, j, l ) -! end do -! end do -! end do -! end if -! end if - -! GFS does not have model level cloud fraction -> derive cloud fraction -! CFR=SPVAL -! allocate(qstl(lm)) -! print*,'start deriving cloud fraction' - -! do j=jsta,jend -! do i=1,im -! do l=1,lm -! if(i==im/2.and.j==jsta)print*,'sample T=',t(i,j,l) -! es=fpvsnew(t(i,j,l)) -! if(i==im/2.and.j==jsta)print*,'sample ES=',es -! es=min(es,pmid(i,j,l)) -! if(i==im/2.and.j==jsta)print*,'sample ES=',es -! qstl(l)=con_eps*es/(pmid(i,j,l)+con_epsm1*es) !saturation q for GFS -! end do -! call progcld1 -!................................... - -! --- inputs: -! & ( pmid(i,j,1:lm)/100.,pint(i,j,1:lm+1)/100., -! & t(i,j,1:lm),q(i,j,1:lm),qstl,cwm(i,j,1:lm), -! & gdlat(i,j),gdlon(i,j), -! & 1, lm, lm+1, 0, -! --- outputs: -! & cfr(i,j,1:lm) -! & ) -! do l=1,lm -! cfr(i,j,l)=cldtot(l) -! end do -! end do -! end do - allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), & - qs2d(im,lm),cfr2d(im,lm)) - do j=jsta,jend -!$omp parallel do private(i,k,es) - do k=1,lm - do i=1,im - p2d(i,k) = pmid(i,j,k)*0.01 - t2d(i,k) = t(i,j,k) - q2d(i,k) = q(i,j,k) - cw2d(i,k) = cwm(i,j,k) - es = min(fpvsnew(t(i,j,k)),pmid(i,j,k)) - qs2d(i,k) = eps*es/(pmid(i,j,k)+epsm1*es)!saturation q for GFS - enddo - enddo - call progcld1 & -!................................... -! --- inputs: - ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, & -! --- outputs: - cfr2d & - ) -!$omp parallel do private(i,k) - do k=1,lm - do i=1,im - cfr(i,j,k) = cfr2d(i,k) - enddo - end do - end do - deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d) - - -! ask murthy if there is snow rate in GFS -! varname='SR' -! call retrieve_index(index,VarName,varname_all,nrecs,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! SR=SPVAL -! else -! this_offset=file_offset(index+1)+(jsta_2l-1)*4*im -! this_length=im*(jend_2u-jsta_2l+1) -! call mpi_file_read_at(iunit,this_offset -! + ,sr,this_length,mpi_real4 -! + , mpi_status_ignore, ierr) -! if (ierr /= 0) then -! print*,"Error reading ", VarName,"Assigned missing values" -! SR=SPVAL -! end if -! end if - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc' - VcoordName='high cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc' - VcoordName='low cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc' - VcoordName='mid cld lay' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdc' - VcoordName='convect-cld laye' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where(buf /= spval)islope=nint(buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m using nemsio - VarName='cnwat' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cmc) -! where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! GFS does not have snow cover yet -! VarName='gflux' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! + ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy,icnt,idsp,mpi_real & -! + , pctsno(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! asuume tg3 in GFS is the same as soiltb in wrf nmm. It's in sfc file, will -! be able to read it when it merges to gfs io -! soiltb is not being put out, comment it out -! VarName='tg3' -! VcoordName='sfc' -! l=1 -! if(me == 0)then -! call gfsio_readrecvw34(gfile,trim(VarName),trim(VcoordName) & -! ,l,dummy,iret=iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dummy=spval -! end if -! end if -! call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & -! , soiltb(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) -! if (iret /= 0)print*,'Error scattering array';stop - -! vegetation fraction in fraction. using nemsio - VarName='veg' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,vegfrc) -! where(vegfrc /= spval) -! vegfrc=vegfrc/100. ! convert to fraction -! elsewhere (vegfrc == spval) -! vegfrc=0. ! set to zero to be reasonable input for crtm -! end where -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,1)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,2)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,3)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sh2o(1,jsta_2l,4)) -! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,1)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,2)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,3)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smc(1,jsta_2l,4)) -! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='tmp' - VcoordName='0-10 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,1)) -! if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='tmp' - VcoordName='10-40 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,2)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='tmp' - VcoordName='40-100 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,3)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='tmp' - VcoordName='100-200 cm down' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,stc(1,jsta_2l,4)) -! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - ssroff(i,j) = spval ! GFS does not have storm runoff - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwin(i,j) = spval ! GFS does not have inst incoming sfc longwave - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave using nemsio - VarName='dlwrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwin) - -! time averaged outgoing sfc longwave using gfsio - VarName='ulwrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwout) -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - rswin(i,j) = spval ! GFS does not have inst incoming sfc shortwave - rswinc(i,j) = spval ! GFS does not have inst incoming clear sky sfc shortwave - rswout(i,j) = spval ! GFS does not have inst outgoing sfc shortwave - enddo - enddo - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave using gfsio - VarName='dswrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! time averaged model top incoming shortwave - VarName='dswrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswintoa) - -! time averaged model top outgoing shortwave - VarName='uswrf' - VcoordName='nom. top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! time averaged ground heat flux using nemsio - VarName='gflux' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,subshx) -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! time averaged zonal momentum flux using gfsio - VarName='uflx' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - snopcx(i,j) =spval ! GFS does not have snow phase change heat flux - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,potevp) -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd' - VcoordName='10 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,u10) -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do - -! 10 m v using gfsio - VarName='vgrd' - VcoordName='10 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,v10) - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vgtyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,buf) -! where (buf /= spval) -! isltyp=nint(buf) -! elsewhere -! isltyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability - smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - sfcexc(i,j) = spval ! GFS does not have surface exchange coefficient - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt - sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptop) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='pres' - VcoordName='convect-cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres' - VcoordName='low cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres' - VcoordName='low cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp' - VcoordName='low cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres' - VcoordName='mid cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres' - VcoordName='mid cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp' - VcoordName='mid cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres' - VcoordName='high cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres' - VcoordName='high cld bot' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp' - VcoordName='high cld top' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc' - VcoordName='bndary-layer cld' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function using nemsio - VarName='cwork' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! retrieve water runoff using nemsio - VarName='watr' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,runoff) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmax' - VcoordName='2 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,maxtshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,maxtshltr(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmin' - VcoordName='2 m above gnd' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,smcwlt) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,suntime) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,suntime(isa,jsa) - -! retrieve field capacity using nemsio - VarName='fldcp' - VcoordName='sfc' - l=1 - call getnemsandscatter(me,ffile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,fieldcapa) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! -!!!! DONE GETTING -! Will derive isobaric OMEGA from continuity equation later. -! OMGA=SPVAL -! -! -! retrieve d3d fields if it's listed -! ---------------------------------- - if (me == 0) print*,'iostatus for d3d file= ',iostatusD3D - if(iostatusD3D == 0) then ! start reading d3d file -! retrieve longwave tendency using getgb - Index=41 - VarName='LW RAD TEMP TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=251 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rlwtt(1,jsta_2l,ll)) - end do - -! retrieve shortwave tendency using getgb - Index=40 - VarName='SW RAD TEMP TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=250 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,rswtt(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion tendency using getgb - Index=356 - VarName='VDIFF TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=246 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdifftt(1,jsta_2l,ll)) - end do - -! retrieve deep convective tendency using getgb - Index=79 - VarName='AVE CNVCT RN TMPTDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=242 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucn(1,jsta_2l,ll)) - end do - -! retrieve shallow convective tendency using getgb - Index=358 - VarName='S CNVCT TNDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=244 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,tcucns(1,jsta_2l,ll)) - end do - -! retrieve grid scale latent heat tendency using getgb - Index=78 - VarName='AVE GRDSCL RN TMPTDY' - jpds=-1.0 - jgds=-1.0 - jpds(5)=241 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,train(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion moistening using getgb - Index=360 - VarName='Vertical diffusion moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=249 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmois(1,jsta_2l,ll)) - end do - -! retrieve deep convection moistening using getgb - Index=361 - VarName='deep convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=243 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,dconvmois(1,jsta_2l,ll)) - end do - -! retrieve shallow convection moistening using getgb - Index=362 - VarName='shallow convection moistening' - jpds=-1.0 - jgds=-1.0 - jpds(5)=245 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,sconvmois(1,jsta_2l,ll)) - end do - -! retrieve non-radiation tendency using getgb - Index=363 - VarName='non-radiation tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=173 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,nradtt(1,jsta_2l,ll)) - end do - -! retrieve Vertical diffusion of ozone using getgb - Index=364 - VarName='Vertical diffusion of ozone' - jpds=-1.0 - jgds=-1.0 - jpds(5)=174 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3vdiff(1,jsta_2l,ll)) - end do - -! retrieve ozone production using getgb - Index=365 - VarName='Ozone production' - jpds=-1.0 - jgds=-1.0 - jpds(5)=175 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3prod(1,jsta_2l,ll)) - end do - -! retrieve ozone tendency using getgb - Index=366 - VarName='Ozone tendency' - jpds=-1.0 - jgds=-1.0 - jpds(5)=188 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,o3tndy(1,jsta_2l,ll)) - end do - -! retrieve mass weighted PV using getgb - Index=367 - VarName='Mass weighted PV' - jpds=-1.0 - jgds=-1.0 - jpds(5)=139 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mwpv(1,jsta_2l,ll)) - end do - -! retrieve OZONE TNDY using getgb - Index=368 - VarName='?' - jpds=-1.0 - jgds=-1.0 - jpds(5)=239 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,unknown(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion zonal acceleration - Index=369 - VarName='VDIFF Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=247 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffzacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag zonal acceleration - Index=370 - VarName='G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=181 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,zgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective U momemtum mixing - Index=371 - VarName='CNVCT U M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=183 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctummixing(1,jsta_2l,ll)) - end do - -! retrieve vertical diffusion meridional acceleration - Index=372 - VarName='VDIFF M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=248 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,vdiffmacce(1,jsta_2l,ll)) - end do - -! retrieve gravity drag meridional acceleration - Index=373 - VarName='G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=182 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,mgdrag(1,jsta_2l,ll)) - end do - -! retrieve convective V momemtum mixing - Index=374 - VarName='CNVCT V M MIX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=184 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctvmmixing(1,jsta_2l,ll)) - end do - -! retrieve nonconvective cloud fraction - Index=375 - VarName='N CNVCT CLD FRA' - jpds=-1.0 - jgds=-1.0 - jpds(5)=213 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,ncnvctcfrac(1,jsta_2l,ll)) - end do - -! retrieve convective upward mass flux - Index=391 - VarName='CNVCT U M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=202 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctumflx(1,jsta_2l,ll)) - end do - -! retrieve convective downward mass flux - Index=392 - VarName='CNVCT D M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=209 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdmflx(1,jsta_2l,ll)) - end do - -! retrieve nonconvective detraintment flux - Index=393 - VarName='CNVCT DET M FLX' - jpds=-1.0 - jgds=-1.0 - jpds(5)=219 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctdetmflx(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag zonal acceleration - Index=394 - VarName='CNVCT G DRAG Z ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=196 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctzgdrag(1,jsta_2l,ll)) - end do - -! retrieve cnvct gravity drag meridional acceleration - Index=395 - VarName='CNVCT G DRAG M ACCE' - jpds=-1.0 - jgds=-1.0 - jpds(5)=197 - jpds(6)=109 - do l=1,lm - jpds(7)=l - ll=lm-l+1 !flip 3d fields to count from top down - call getgbandscatter(me,iunitd3d,im,jm,im_jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,jpds,jgds,kpds,cnvctmgdrag(1,jsta_2l,ll)) - end do - - call baclose(iunitd3d,status) - print*,'done reading D3D fields' - - end if ! end of d3d file read - ! -------------------- - print *,'after d3d files reading,mype=',me - -! Retrieve aer fields if it's listed (GOCART) - print *, 'iostatus for aer file=', iostatusAER - if(iostatusAER == 0) then ! start reading aer file - -! retrieve dust emission fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUEM001' - if ( K == 2) VarName='DUEM002' - if ( K == 3) VarName='DUEM003' - if ( K == 4) VarName='DUEM004' - if ( K == 5) VarName='DUEM005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,duem(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',duem(isa,jsa,k) - enddo - -! retrieve dust sedimentation fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUSD001' - if ( K == 2) VarName='DUSD002' - if ( K == 3) VarName='DUSD003' - if ( K == 4) VarName='DUSD004' - if ( K == 5) VarName='DUSD005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusd(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',dusd(isa,jsa,k) - enddo - -! retrieve dust dry deposition fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUDP001' - if ( K == 2) VarName='DUDP002' - if ( K == 3) VarName='DUDP003' - if ( K == 4) VarName='DUDP004' - if ( K == 5) VarName='DUDP005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dudp(1,jsta_2l,K)) - print *,'dudp,ck=',maxval(dudp(1:im,jsta:jend,k)), & - minval(dudp(1:im,jsta:jend,k)) -! if(debugprint)print*,'sample ',VarName,' = ',dudp(isa,jsa,k) - enddo - -! retrieve dust wet deposition fluxes - do K = 1, nbin_du - if ( K == 1) VarName='DUWT001' - if ( K == 2) VarName='DUWT002' - if ( K == 3) VarName='DUWT003' - if ( K == 4) VarName='DUWT004' - if ( K == 5) VarName='DUWT005' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,duwt(1,jsta_2l,K)) -! if(debugprint)print*,'sample ',VarName,' = ',duwt(isa,jsa,k) - enddo - -! retrieve sfc mass concentration - VarName='DUSMASS' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusmass) -! if(debugprint)print*,'sample ',VarName,' = ',dusmass(isa,jsa) - -! retrieve col mass density - VarName='DUCMASS' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ducmass) -! if(debugprint)print*,'sample ',VarName,' = ',ducmass(isa,jsa) - -! retrieve sfc mass concentration (pm2.5) - VarName='DUSMASS25' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,dusmass25) -! if(debugprint)print*,'sample ',VarName,' = ',dusmass25(isa,jsa) - -! retrieve col mass density (pm2.5) - VarName='DUCMASS25' - VcoordName='atmos col' - l=1 - call getnemsandscatter(me,rfile,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,VcoordName & - ,l,im,jm,nframe,ducmass25) -! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa) - - if (me == 0) print *,'after aer files reading,mype=',me - end if ! end of aer file read - -! pos east - call collect_loc(gdlat,dummy) - if(me == 0)then - latstart = nint(dummy(1,1)*gdsdegr) - latlast = nint(dummy(im,jm)*gdsdegr) - print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& - 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) - end if - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me - call collect_loc(gdlon,dummy) - if(me == 0)then - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! -! ncdump -h -!! -!! - write(6,*) 'filename in INITPOST=', filename,' is' - -! status=nf_open(filename,NF_NOWRITE,ncid) -! write(6,*) 'returned ncid= ', ncid -! status=nf_get_att_real(ncid,varid,'DX',tmp) -! dxval=int(tmp) -! status=nf_get_att_real(ncid,varid,'DY',tmp) -! dyval=int(tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) -! cenlat=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) -! cenlon=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) -! truelat1=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) -! truelat2=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) -! maptype=int(tmp) -! status=nf_close(ncid) - -! dxval=30000. -! dyval=30000. -! -! write(6,*) 'dxval= ', dxval -! write(6,*) 'dyval= ', dyval -! write(6,*) 'cenlat= ', cenlat -! write(6,*) 'cenlon= ', cenlon -! write(6,*) 'truelat1= ', truelat1 -! write(6,*) 'truelat2= ', truelat2 -! write(6,*) 'maptype is ', maptype -! - -! close up shop -! call ext_int_ioclose ( DataHandle, Status ) - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT -! TPREC=float(ifhr) -!MEB need to get DT - -!how am i going to get this information? -! NPREC = INT(TPREC *TSPH+D50) -! NHEAT = INT(THEAT *TSPH+D50) -! NCLOD = INT(TCLOD *TSPH+D50) -! NRDSW = INT(TRDSW *TSPH+D50) -! NRDLW = INT(TRDLW *TSPH+D50) -! NSRFC = INT(TSRFC *TSPH+D50) -!how am i going to get this information? -! -! IF(ME == 0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! close all files -! - call nemsio_close(nfile,iret=status) - call nemsio_close(ffile,iret=status) - call nemsio_close(rfile,iret=status) -! call baclose(iunit,status) - - RETURN - END - - diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f index 4714cfc3d..cca50d7b2 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f @@ -1,51 +1,31 @@ !> @file -! . . . -!> SUBPROGRAM: INITPOST_GFS_NEMS_MPIIO INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2011-02-07 Jun Wang add grib2 option -!! 2011-12-14 Sarah Lu add aer option -!! 2012-01-07 Sarah Lu compute air density -!! 2012-12-22 Sarah Lu add aerosol zerout option -!! 2015-03-16 S. Moorthi adding gocart_on option -!! 2015-03-18 S. Moorthi Optimization including threading -!! 2015-08-17 S. Moorthi Add TKE for NEMS/GSM -!! 2016-03-04 H CHUANG Add MPI IO option to read GFS nems output -!! 2016-05-16 S. KAR Add computation of omega -!! 2016-07-21 S. Moorthi Convert input upper air data from reduced to full grid -!! and reduce memory in divergence calculatiom -!! 2016-07-21 Jun Wang change averaged field name with suffix -!! 2019-07-24 Li(Kate) Zhang - Merge and update NGAC UPP into FV3-Chem -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief initpost_gfs_nems_mpiio() initializes post for run. +!> +!> @author Hui-Ya Chuang @date 2007-03-04 + +!> This routine initializes constants and +!> variables at the start of GFS model or post +!> processor run. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-03-04 | Hui-Ya Chuang | Initial +!> 2011-02-07 | Jun Wang | Add grib2 option +!> 2011-12-14 | Sarah Lu | Add aer option +!> 2012-01-07 | Sarah Lu | Compute air density +!> 2012-12-22 | Sarah Lu | Add aerosol zerout option +!> 2015-03-16 | S. Moorthi | Adding gocart_on option +!> 2015-03-18 | S. Moorthi | Optimization including threading +!> 2015-08-17 | S. Moorthi | Add TKE for NEMS/GSM +!> 2016-03-04 | H Chuang | Add MPI IO option to read GFS nems output +!> 2016-05-16 | S. Kar | Add computation of omega +!> 2016-07-21 | S. Moorthi | Convert input upper air data from reduced to full grid and reduce memory in divergence calculatiom +!> 2016-07-21 | Jun Wang | Change averaged field name with suffix +!> 2019-07-24 | Li(Kate) Zhang | Merge and update NGAC UPP into FV3-Chem +!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend) +!> +!> @author Hui-Ya Chuang @date 2007-03-04 SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) @@ -75,8 +55,8 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont, & avisbeamswin,avisdiffswin,airbeamswin,airdiffswin, & alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - dustcb,bccb,occb,sulfcb,sscb,dustallcb,ssallcb,dustpm,sspm,pp25cb,pp10cb, & - ti + dustcb,bccb,occb,sulfcb,sscb,dustallcb,ssallcb,dustpm,dustpm10,sspm,pp25cb, & + pp10cb,maod,ti use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice ! use kinds, only: i_llong @@ -96,7 +76,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & dxval, dyval, truelat2, truelat1, psmapf, cenlat use nemsio_module_mpi - use upp_physics, only: fpvsnew + use upp_physics, only: fpvsnew, caldiv, calgradps !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -375,7 +355,8 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) print *,me,'max(gdlat)=', maxval(gdlat), & 'max(gdlon)=', maxval(gdlon) - CALL EXCH(gdlat(1,JSTA_2L)) + CALL EXCH(gdlat) + CALL EXCH(gdlon) print *,'after call EXCH,me=',me !$omp parallel do private(i,j,ip1) @@ -1433,7 +1414,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) dustallcb(1:im,jsta_2l:jend_2u)=dustallcb(1:im,jsta_2l:jend_2u)+ & (dust(1:im,jsta_2l:jend_2u,ll,1)+dust(1:im,jsta_2l:jend_2u,ll,2)+ & - dust(1:im,jsta_2l:jend_2u,ll,3)+0.67*dust(1:im,jsta_2l:jend_2u,ll,4))* & + dust(1:im,jsta_2l:jend_2u,ll,3)+0.74*dust(1:im,jsta_2l:jend_2u,ll,4))* & dpres(1:im,jsta_2l:jend_2u,ll)/grav ! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5) @@ -1490,7 +1471,8 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) ,salt(1:im,jsta_2l:jend_2u,ll,3)) sscb(1:im,jsta_2l:jend_2u)=sscb(1:im,jsta_2l:jend_2u)+ & - (salt(1:im,jsta_2l:jend_2u,ll,2)+0.75*salt(1:im,jsta_2l:jend_2u,ll,3))* & + (salt(1:im,jsta_2l:jend_2u,ll,1)+ & + salt(1:im,jsta_2l:jend_2u,ll,2)+0.83*salt(1:im,jsta_2l:jend_2u,ll,3))* & dpres(1:im,jsta_2l:jend_2u,ll)/grav ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3) @@ -1521,7 +1503,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) ssallcb(1:im,jsta_2l:jend_2u)=ssallcb(1:im,jsta_2l:jend_2u)+ & (salt(1:im,jsta_2l:jend_2u,ll,1)+salt(1:im,jsta_2l:jend_2u,ll,2)+ & salt(1:im,jsta_2l:jend_2u,ll,3)+ & - salt(1:im,jsta_2l:jend_2u,ll,4)*0.83)* & + salt(1:im,jsta_2l:jend_2u,ll,4))* & dpres(1:im,jsta_2l:jend_2u,ll)/grav ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5) @@ -1748,17 +1730,18 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) bccb(i,j) = MAX(bccb(i,j), 0.0) occb(i,j) = MAX(occb(i,j), 0.0) sulfcb(i,j) = MAX(sulfcb(i,j), 0.0) - pp25cb(i,j) = MAX(sulfcb(i,j), 0.0) - pp10cb(i,j) = MAX(sulfcb(i,j), 0.0) + pp25cb(i,j) = MAX(pp25cb(i,j), 0.0) + pp10cb(i,j) = MAX(pp10cb(i,j), 0.0) ! PM10 concentration dusmass(i,j)=(dust(i,j,l,1)+dust(i,j,l,2)+dust(i,j,l,3)+ & 0.74*dust(i,j,l,4)+salt(i,j,l,1)+salt(i,j,l,2)+salt(i,j,l,3)+ & - salt(i,j,l,4) + & - salt(i,j,l,5)+soot(i,j,l,1)+soot(i,j,l,2)+waso(i,j,l,1)+ & + salt(i,j,l,4) + soot(i,j,l,1)+soot(i,j,l,2)+waso(i,j,l,1)+ & waso(i,j,l,2) +suso(i,j,l,1)+pp25(i,j,l,1)+pp10(i,j,l,1)) & *RHOMID(i,j,l) !ug/m3 ! PM25 dust and seasalt dustpm(i,j)=(dust(i,j,l,1)+0.38*dust(i,j,l,2))*RHOMID(i,j,l) !ug/m3 + dustpm10(i,j)=(dust(i,j,l,1)+dust(i,j,l,2)+dust(i,j,l,3)+ & + 0.74*dust(i,j,l,4))*RHOMID(i,j,l) !ug/m3 sspm(i,j)=(salt(i,j,l,1)+salt(i,j,l,2)+ & 0.83*salt(i,j,l,3))*RHOMID(i,j,l) !ug/m3 ! PM25 concentration @@ -3693,43 +3676,6 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) enddo enddo -! done with flux file, close it for now - call nemsio_close(ffile,iret=status) - deallocate(tmp,recname,reclevtyp,reclev) - - -! Retrieve aer fields if it's listed (GOCART) - print *, 'iostatus for aer file=', iostatusAER - if(iostatusAER == 0) then ! start reading aer file - call nemsio_open(rfile,trim(fileNameAER),'read',mpi_comm_comp & - ,iret=status) - if ( Status /= 0 ) then - print*,'error opening ',fileNameAER, ' Status = ', Status - endif - call nemsio_getfilehead(rfile,iret=status,nrec=nrec) - print*,'nrec for aer file=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - call nemsio_getfilehead(rfile,iret=iret,recname=recname & - ,reclevtyp=reclevtyp,reclev=reclev) - if(debugprint)then - if (me == 0)then - do i=1,nrec - print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', & - trim(reclevtyp(i)),reclev(i) - end do - end if - end if -! start reading nemsio aer files using parallel read - fldsize=(jend-jsta+1)*im - allocate(tmp(fldsize*nrec)) - print*,'allocate tmp successfully' - tmp=0. - call nemsio_denseread(rfile,1,im,jsta,jend,tmp,iret=iret) - if(iret/=0)then - print*,"fail to read aer file using mpi io read, stopping" - stop - end if - ! retrieve dust emission fluxes do K = 1, nbin_du if ( K == 1) VarName='duem001' @@ -3737,7 +3683,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='duem003' if ( K == 4) VarName='duem004' if ( K == 5) VarName='duem005' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3748,12 +3694,12 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) ! retrieve dust sedimentation fluxes do K = 1, nbin_du - if ( K == 1) VarName='dust1SD' - if ( K == 2) VarName='dust2SD' - if ( K == 3) VarName='dust3SD' - if ( K == 4) VarName='dust4SD' - if ( K == 5) VarName='dsut5SD' - VcoordName='atmos col' + if ( K == 1) VarName='dust1sd' + if ( K == 2) VarName='dust2sd' + if ( K == 3) VarName='dust3sd' + if ( K == 4) VarName='dust4sd' + if ( K == 5) VarName='dsut5sd' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3769,7 +3715,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='dust3dp' if ( K == 4) VarName='dust4dp' if ( K == 5) VarName='dust5dp' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3787,7 +3733,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='dust3wtl' if ( K == 4) VarName='dust4wtl' if ( K == 5) VarName='dust5wtl' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3801,7 +3747,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='dust3wtc' if ( K == 4) VarName='dust4wtc' if ( K == 5) VarName='dust5wtc' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3816,13 +3762,29 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='ssem003' if ( K == 4) VarName='ssem004' if ( K == 5) VarName='ssem005' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & ,recname,reclevtyp,reclev,VarName,VcoordName& ,ssem(1,jsta_2l,K)) enddo + +! retrieve seasalt emission fluxes + do K = 1, nbin_ss + if ( K == 1) VarName='seas1sd' + if ( K == 2) VarName='seas2sd' + if ( K == 3) VarName='seas3sd' + if ( K == 4) VarName='seas4sd' + if ( K == 5) VarName='seas5sd' + VcoordName='sfc' + l=1 + call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & + ,l,nrec,fldsize,spval,tmp & + ,recname,reclevtyp,reclev,VarName,VcoordName& + ,sssd(1,jsta_2l,K)) + enddo + ! retrieve seasalt dry deposition fluxes do K = 1, nbin_ss @@ -3831,7 +3793,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='seas3dp' if ( K == 4) VarName='seas4dp' if ( K == 5) VarName='seas5dp' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3846,7 +3808,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='seas3wtl' if ( K == 4) VarName='seas4wtl' if ( K == 5) VarName='seas5wtl' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3861,7 +3823,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) if ( K == 3) VarName='seas1wtc' if ( K == 4) VarName='seas1wtc' if ( K == 5) VarName='seas1wtc' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3873,7 +3835,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_bc if ( K == 1) VarName='bceman' if ( K == 2) VarName='bcembb' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3885,7 +3847,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_bc if ( K == 1) VarName='bc1sd' if ( K == 2) VarName='bc2sd' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3897,7 +3859,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_bc if ( K == 1) VarName='bc1dp' if ( K == 2) VarName='bc2dp' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3909,7 +3871,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_bc if ( K == 1) VarName='bc1wtl' if ( K == 2) VarName='bc2wtl' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3921,7 +3883,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_bc if ( K == 1) VarName='bc1wtc' if ( K == 2) VarName='bc2wtc' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3933,7 +3895,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_oc if ( K == 1) VarName='oceman' if ( K == 2) VarName='ocembb' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3945,7 +3907,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_oc if ( K == 1) VarName='oc1sd' if ( K == 2) VarName='oc2sd' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3955,9 +3917,9 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) ! retrieve oc dry deposition fluxes do K = 1, nbin_oc - if ( K == 1) VarName='c1dp' - if ( K == 2) VarName='c2dp' - VcoordName='atmos col' + if ( K == 1) VarName='oc1dp' + if ( K == 2) VarName='oc2dp' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3969,7 +3931,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_oc if ( K == 1) VarName='oc1wtl' if ( K == 2) VarName='oc2wtl' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3981,7 +3943,7 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) do K = 1, nbin_oc if ( K == 1) VarName='oc1wtc' if ( K == 2) VarName='oc2wtc' - VcoordName='atmos col' + VcoordName='atmos sfc' l=1 call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & ,l,nrec,fldsize,spval,tmp & @@ -3989,8 +3951,20 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) ,ocsv(1,jsta_2l,K)) enddo +! retrieve MIE AOD + VarName='maod' + VcoordName='sfc' + l=1 + call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & + ,l,nrec,fldsize,spval,tmp & + ,recname,reclevtyp,reclev,VarName,VcoordName& + ,maod(1,jsta_2l)) +! done with flux file, close it for now + call nemsio_close(ffile,iret=status) + deallocate(tmp,recname,reclevtyp,reclev) + !lzhang !! retrieve sfc mass concentration ! VarName='DUSMASS' @@ -4035,11 +4009,6 @@ SUBROUTINE INITPOST_GFS_NEMS_MPIIO(iostatusAER) ! ,ducmass25) ! if(debugprint)print*,'sample ',VarName,' = ',ducmass25(isa,jsa) - if (me == 0) print *,'after aer files reading,mype=',me - call nemsio_close(rfile,iret=status) - deallocate(tmp,recname,reclevtyp,reclev) - end if ! end of aer file read - ! pos east call collect_loc(gdlat,dummy) if(me == 0)then diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f deleted file mode 100644 index b61732212..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF.f +++ /dev/null @@ -1,2761 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NETCDF -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NETCDF(ncid3d) - - - use netcdf - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10 - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, & - wh, qqg, ref_10cm - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & - maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & - up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & - avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & - avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & - alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & - latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r - use upp_physics, only: fpvsnew -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! type(nemsio_gfile) :: nfile,ffile,rfile - integer,parameter :: nvar2d=48 -! character(nemsio_charkind) :: name2d(nvar2d) - integer :: nvar3d, numDims -! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) -! character(nemsio_charkind) :: varname,levtype -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - character(len=20) :: VarName, VcoordName - integer :: Status, fldsize, fldst, recn, recn_vvel - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL -! logical, parameter :: debugprint = .true., zerout = .false. - logical, parameter :: debugprint = .false., zerout = .false. - logical :: convert_rad_to_deg=.false. - CHARACTER*32 varcharval -! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour -! integer nfhour ! forecast hour from nems io file - integer fhzero !bucket - real dtp !physics time step - REAL RINC(5) - -! REAL FI(IM,JM,2) - REAL DUMMY(IM,JM) - -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - nframed2,iunitd3d,ierr,idum,iret,nrec,idrt - integer ncid3d,ncid2d,varid,nhcas - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv, tx1, tx2 - - character*20,allocatable :: recname(:) - integer, allocatable :: reclev(:), kmsk(:,:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - real, allocatable :: tmp(:) - real :: buf(im,jsta_2l:jend_2u) - real :: buf3d(im,jsta_2l:jend_2u,lm) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT - integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass - - integer, parameter :: npass2=5, npass3=30 - real, parameter :: third=1.0/3.0 - INTEGER, DIMENSION(2) :: ij4min, ij4max - REAL :: omgmin, omgmax - real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:) - REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:) - real, allocatable :: div3d(:,:,:) - real(kind=4),allocatable :: vcrd(:,:) - real :: dum_const - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF' - WRITE(6,*)'me=',me, & - 'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo - - Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5) - if(Status/=0)then - print*,'ak not found; assigning missing value' - ak5=spval - else - if(me==0)print*,'ak5= ',ak5 - end if - Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt) - if(Status/=0)then - print*,'idrt not in netcdf file,reading grid' - Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval) - if(Status/=0)then - print*,'idrt and grid not in netcdf file, set default to latlon' - idrt=0 - MAPTYPE=0 - else - if(trim(varcharval)=='rotated_latlon')then - MAPTYPE=207 - idrt=207 - Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const) - if(Status/=0)then - print*,'cen_lon not found; assigning missing value' - cenlon=spval - else - if(dum_const<0.)then - cenlon=nint((dum_const+360.)*gdsdegr) - else - cenlon=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const) - if(Status/=0)then - print*,'cen_lat not found; assigning missing value' - cenlat=spval - else - cenlat=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart_r not found; assigning missing value' - lonstart_r=spval - else - if(dum_const<0.)then - lonstart_r=nint((dum_const+360.)*gdsdegr) - else - lonstart_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart_r not found; assigning missing value' - latstart_r=spval - else - latstart_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast_r not found; assigning missing value' - lonlast_r=spval - else - if(dum_const<0.)then - lonlast_r=nint((dum_const+360.)*gdsdegr) - else - lonlast_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast_r not found; assigning missing value' - latlast_r=spval - else - latlast_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & - lonstart,latstart,cenlon,cenlat,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) start - else if(trim(varcharval)=='latlon')then - MAPTYPE=0 - idrt=0 - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart not found; assigning missing value' - lonstart=spval - else - if(dum_const<0.)then - lonstart=nint((dum_const+360.)*gdsdegr) - else - lonstart=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart not found; assigning missing value' - latstart=spval - else - latstart=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast not found; assigning missing value' - lonlast=spval - else - if(dum_const<0.)then - lonlast=nint((dum_const+360.)*gdsdegr) - else - lonlast=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast not found; assigning missing value' - latlast=spval - else - latlast=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,dyval,dxval', & - lonstart,lonlast,latstart,latlast,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) end - - else if(trim(varcharval)=='gaussian')then - MAPTYPE=4 - idrt=4 - else ! setting default maptype - MAPTYPE=0 - idrt=0 - end if - end if !end reading grid - end if !end reading idrt - if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do - - Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas) - if(Status/=0)then - print*,'nhcas not in netcdf file, set default to nonhydro' - nhcas=0 - end if - if(me==0)print*,'nhcas= ',nhcas - if (nhcas == 0 ) then !non-hydrostatic case - nrec=15 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', & - 'presnh','dzdt', 'clwmr','dpres', & - 'delz','icmr','rwmr', & - 'snmr','grle','cld_amt'] - else - nrec=8 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', & - 'hypres', 'clwmr','dpres'] - endif - -! write(0,*)'nrec=',nrec - !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) - -! hardwire idate for now -! idate=(/2017,08,07,00,0,0,0,0/) -! get cycle start time - Status=nf90_inq_varid(ncid3d,'time',varid) - if(Status/=0)then - print*,'time not in netcdf file, stopping' - STOP 1 - else - Status=nf90_get_att(ncid3d,varid,'units',varcharval) - if(Status/=0)then - print*,'time unit not available' - else - print*,'time unit read from netcdf file= ',varcharval -! assume use hours as unit -! idate_loc=index(varcharval,'since')+6 - read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5) - end if -! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes) -! allocate(fhours(ntimes)) -! status = nf90_inq_varid(ncid3d,varid,fhours) -! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), & -! count=(/1/)) -! if(Status/=0)then -! print*,'forecast hour not in netcdf file, stopping' -! STOP 1 -! end if - end if - 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'idate= ',idate(1:5) -! get longitude - Status=nf90_inq_varid(ncid3d,'grid_xt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlon ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glon1d) - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(glon1d(i),kind=4) - end do - end do - lonstart = nint(glon1d(1)*gdsdegr) - lonlast = nint(glon1d(im)*gdsdegr) - dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. - if(convert_rad_to_deg)then - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi - end do - end do - else - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4) - end do - end do - end if - if(convert_rad_to_deg)then - lonstart = nint(dummy(1,1)*gdsdegr)*180./pi - lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi - else - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr) - end if - -! Jili Dong add support for regular lat lon (2019/03/22) start - if (MAPTYPE == 0) then - if(lonstart<0.)then - lonstart=lonstart+360.*gdsdegr - end if - if(lonlast<0.)then - lonlast=lonlast+360.*gdsdegr - end if - end if -! Jili Dong add support for regular lat lon (2019/03/22) end - - end if - print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval -! get latitude - Status=nf90_inq_varid(ncid3d,'grid_yt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlat ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glat1d) - do j=jsta,jend - do i=1,im - gdlat(i,j) = real(glat1d(j),kind=4) - end do - end do - latstart = nint(glat1d(1)*gdsdegr) - latlast = nint(glat1d(jm)*gdsdegr) - dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))1.0e5)print*,'bad dpres ',i,j,dpres(i,j,l) -!make sure delz is positive -! if(dpres(i,j,l)/=spval .and. t(i,j,l)/=spval .and. & -! q(i,j,l)/=spval .and. buf3d(i,j,l)/=spval)then -! pmid(i,j,l)=rgas*dpres(i,j,l)* & -! t(i,j,l)*(q(i,j,l)*fv+1.0)/grav/abs(buf3d(i,j,l)) -! else -! pmid(i,j,l)=spval -! end if -! dong add missing value - if (wh(i,j,l) < spval) then - omga(i,j,l)=(-1.)*wh(i,j,l)*dpres(i,j,l)/abs(buf3d(i,j,l)) - else - omga(i,j,l) = spval - end if -! if(t(i,j,l)>1000.)print*,'bad T ',t(i,j,l) - enddo - enddo - enddo - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(11) & - ,lm,qqi(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(12) & - ,lm,qqr(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(13) & - ,lm,qqs(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(14) & - ,lm,qqg(1,jsta_2l,1)) - call read_netcdf_3d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,recname(15) & - ,lm,cfr(1,jsta_2l,1)) -! calculate CWM from FV3 output - do l=1,lm - do j=jsta,jend - do i=1,im - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) - enddo - enddo - if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l & - ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) & - ,wh(isa,jsa,l) - if(debugprint)print*,'sample l cwm for FV3',l, & - cwm(isa,jsa,l) - end do -! max hourly updraft velocity -! VarName='upvvelmax' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_up_max) -! if(debugprint)print*,'sample ',VarName,' = ',w_up_max(isa,jsa) - -! max hourly downdraft velocity -! VarName='dnvvelmax' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,w_dn_max) -! if(debugprint)print*,'sample ',VarName,' = ',w_dn_max(isa,jsa) -! max hourly updraft helicity -! VarName='uhmax25' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max(isa,jsa) -! min hourly updraft helicity -! VarName='uhmin25' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min(isa,jsa) -! max hourly 0-3km updraft helicity -! VarName='uhmax03' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_max03) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_max03(isa,jsa) -! min hourly 0-3km updraft helicity -! VarName='uhmin03' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,up_heli_min03) -! if(debugprint)print*,'sample ',VarName,' = ',up_heli_min03(isa,jsa) - -! max 0-1km relative vorticity max -! VarName='maxvort01' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max01) -! if(debugprint)print*,'sample ',VarName,' = ',rel_vort_max01(isa,jsa) -! max 0-2km relative vorticity max -! VarName='maxvort02' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_max) -! if(debugprint)print*,'sample ',VarName,' =',rel_vort_max(isa,jsa) -! max hybrid lev 1 relative vorticity max -! VarName='maxvorthy1' -! call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rel_vort_maxhy1) -! if(debugprint)print*,'sample ',VarName,' =',rel_vort_maxhy1(isa,jsa) -! surface pressure - VarName='pressfc' - call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,pint(1,jsta_2l,lp1)) - do j=jsta,jend - do i=1,im -! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & -! print*,'bad psfc ',i,j,pint(i,j,lp1) - end do - end do - if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) - - pt = ak5(1) - - do j=jsta,jend - do i=1,im - pint(i,j,1)= pt - end do - end do - - do l=2,lp1 - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo -! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l & -! ,pint(ii,jj,l),pmid(ii,jj,l) - end do - -!compute pmid from averaged two layer pint - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) - enddo - enddo - enddo - -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! if(pint(i,j,l+1)/=spval .and. dpres(i,j,l)/=spval)then -! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) -! else -! pint(i,j,l)=spval -! end if -! end do -! end do -! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) -! end do - -! surface height from FV3 -! dong set missing value for zint -! zint=spval - VarName='hgtsfc' - call read_netcdf_2d_scatter(me,ncid3d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & - ,zint(1,jsta_2l,lp1)) - if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) - do j=jsta,jend - do i=1,im - if (zint(i,j,lp1) /= spval) then - fis(i,j) = zint(i,j,lp1) * grav - else - fis(i,j) = spval - endif - enddo - enddo - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -!make sure delz is positive - zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) - else - zint(i,j,l)=spval - end if - end do - end do - print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) - end do - - do l=lp1,1,-1 - do j=jsta,jend - do i=1,im - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & - .and. pmid(i,j,l)/=spval)then - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) - else - zmid(i,j,l)=spval - endif - end do - end do - end do - - - pt = ak5(1) - -! else -! do l=2,lm -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) -! enddo -! enddo -! if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l) -! end do -! endif -! - - deallocate (vcoord4) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! - -! done with 3d file, close it for now - Status=nf90_close(ncid3d) - deallocate(recname) - -! open flux file - Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d) - - if ( Status /= 0 ) then - print*,'error opening ',fileNameFlux, ' Status = ', Status - print*,'skip reading of flux file' - endif - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC) - if (Status /= 0) then - print*,VarName,' not found-Assigned 1 for IGBP as default' - IVEGSRC=1 - end if - if (me == 0) print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - if (me == 0) print*,'novegtype= ',novegtype - - Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) - if (Status /= 0) then - print*,VarName,' not found-Assigned 11 GFDL as default' - imp_physics=11 - end if - if (me == 0) print*,'MP_PHYSICS= ',imp_physics -! - Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero) - if (Status /= 0) then - print*,VarName,' not found-Assigned 3 hours as default' - fhzero=3 - end if - if (me == 0) print*,'fhzero= ',fhzero -! - Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp) - if (Status /= 0) then - print*,VarName,' not found-Assigned 90s as default' - dtp=90 - end if - if (me == 0) print*,'dtp= ',dtp -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then - CALL MICROINIT(imp_physics) - end if - -! Chuang: zhour is when GFS empties bucket last so using this -! to compute buket will result in changing bucket with forecast time. -! set default bucket for now - -! call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret) -! if(iret == 0) then -! tprec = 1.0*ifhr-zhour -! tclod = tprec -! trdlw = tprec -! trdsw = tprec -! tsrfc = tprec -! tmaxmin = tprec -! td3d = tprec -! print*,'tprec from flux file header= ',tprec -! else -! print*,'Error reading accumulation bucket from flux file', & -! 'header - will try to read from env variable FHZER' -! CALL GETENV('FHZER',ENVAR) -! read(ENVAR, '(I2)')idum -! tprec = idum*1.0 -! tclod = tprec -! trdlw = tprec -! trdsw = tprec -! tsrfc = tprec -! tmaxmin = tprec -! td3d = tprec -! print*,'TPREC from FHZER= ',tprec -! end if - - - tprec = float(fhzero) - if(ifhr>240)tprec=12. - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec = ',tprec - - -! start reading 2d netcdf file -! surface pressure -! VarName='pressfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & -! ,pint(1,jsta_2l,lp1)) -! if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! pint(i,j,l)=pint(i,j,l+1)-dpres(i,j,l) -! if(pint(i,j,l)>1.0E6)print*,'bad P ',i,j,l,pint(i,j,l) & -! ,pint(i,j,l+1),dpres(i,j,l) -! end do -! end do -! print*,'sample pint= ',isa,jsa,l,pint(isa,jsa,l) -! end do -! surface height from FV3 already multiplied by G -! VarName='orog' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fis) -! if(debugprint)print*,'sample ',VarName,' =',fis(isa,jsa) -! do j=jsta,jend -! do i=1,im -! if (fis(i,j) /= spval) then -! zint(i,j,lp1) = fis(i,j) -! fis(i,j) = fis(i,j) * grav -! else -! zint(i,j,lp1) = spval -! fis(i,j) = spval -! endif -! enddo -! enddo - -! do l=lm,1,-1 -! do j=jsta,jend -! do i=1,im -! if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -! zint(i,j,l)=zint(i,j,l+1)+buf3d(i,j,l) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) -! else -! zint(i,j,l)=spval -! end if -! end do -! end do -! print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) -! end do - -! Per communication with Fanglin, P from model in not monotonic -! so compute P using ak and bk for now Sep. 2017 -! do l=lm,1,-1 -!!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1) -! pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) ! for now - -! enddo -! enddo -! print*,'sample pint,pmid' & -! ,l,pint(isa,jsa,l),pmid(isa,jsa,l) -! enddo - -! allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend)) -! do j=jsta,jend -! do i=1,im -! pd(i,j) = spval ! GFS does not output PD -! pint(i,j,1) = PT -! alpint(i,j,lp1) = log(pint(i,j,lp1)) -! wrk1(i,j) = log(PMID(I,J,LM)) -! wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0) -! FI(I,J,1) = FIS(I,J) & -! + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j)) -! ZMID(I,J,LM) = FI(I,J,1) * gravi -! end do -! end do - -! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on -! mid-layer - -! DO L=LM,2,-1 ! omit computing model top height -! ll = l - 1 -! do j = jsta, jend -! do i = 1, im -! alpint(i,j,l) = log(pint(i,j,l)) -! tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0) -! pmll = log(PMID(I,J,LL)) - -! FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) & -! * (wrk1(i,j)-pmll) -! ZMID(I,J,LL) = FI(I,J,2) * gravi -! -! FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j)) -! ZINT(I,J,L) = ZMID(I,J,L) +(ZMID(I,J,LL)-ZMID(I,J,L))*FACT -! FI(I,J,1) = FI(I,J,2) -! wrk1(i,J) = pmll -! wrk2(i,j) = tvll -! ENDDO -! ENDDO - -! print*,'L ZINT= ',l,zint(isa,jsa,l),ZMID(isa,jsa,l) -! ,'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)), & -! 'pmid(l-1)=',LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L), & -! 'zmid(l-1)=',ZMID(Ii,Jj,L-1) -! ENDDO -! deallocate(wrk1,wrk2) - -! do l=lp1,2,-1 -! do j=jsta,jend -! do i=1,im -! alpint(i,j,l)=log(pint(i,j,l)) -! end do -! end do -! end do - -! do l=lm,2,-1 -! do j=jsta,jend -! do i=1,im -! zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & -! (log(pmid(i,j,l))-alpint(i,j,l+1))/ & -! (alpint(i,j,l)-alpint(i,j,l+1)) -! if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) -! end do -! end do -! end do - -! VarName='refl_10cm' -! do l=1,lm -! call read_netcdf_3d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName & -! ,lm,REF_10CM(1,jsta_2l,1)) -! if(debugprint)print*,'sample ',VarName,'isa,jsa,l =' & -! ,REF_10CM(isa,jsa,l),isa,jsa,l -! enddo -!Set REF_10CM as missning since gfs doesn't ouput it - do l=1,lm - do j=jsta,jend - do i=1,im - REF_10CM(i,j,l)=spval - enddo - enddo - enddo - - VarName='land' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sm) - if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo - -! sea ice mask - - VarName = 'icec' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sice) - if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea -! mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, -! these -! points have sea ice changed to zero, i.e., trust land mask more than -! sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - - -! PBL height using nemsio - VarName = 'hpbl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblh) - if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! sfc exchange coeff - VarName='sfexc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SFCEXC) - -! aerodynamic conductance - VarName='acond' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,acond) - if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) -! mid day avg albedo - VarName='albdo_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) - if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo - -! surface potential T using getgb - VarName='tmpsfc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux -!assign sst - if (sm(i,j) /= 0.0) then - sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa - else - sst(i,j) = spval - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway -! NPHS=1. -! DT=90. -! DTQ2 = DT * NPHS !MEB need to get physics DT - DTQ2 = DTP !MEB need to get physics DT - NPHS=1 - DT = DTQ2/NPHS !MEB need to get DT - TSPH = 3600./DT - -! convective precip in m per physics time step using getgb -! read 3 hour bucket - VarName='cpratb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! read continuous bucket - VarName='cprat_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcprate_cont) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & - avgcprate_cont(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prateb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - -! prec = avgprec !set avg cprate to inst one to derive other fields - - VarName='prate_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgprec_cont) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & - * (dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) -! precip rate in m per physics time step - VarName='tprcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,prec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & - * 1000. / dtp - enddo - enddo - -! convective precip rate in m per physics time step - VarName='cnvprcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cprate) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cprate(i,j) /= spval) then - cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & - * 1000. / dtp - else - cprate(i,j) = 0. - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa) - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - -! max hourly 1-km agl reflectivity -! VarName='refdmax' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max) -! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa) -! max hourly -10C reflectivity -! VarName='refdmax263k' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max) -! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa) - -! max hourly u comp of 10m agl wind -! VarName='u10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max) -! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa) -! max hourly v comp of 10m agl wind -! VarName='v10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max) -! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa) -! max hourly 10m agl wind speed -! VarName='spd10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max) -! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa) - - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! inst snow water eqivalent using nemsio - VarName='weasd' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sno) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! ave snow cover - VarName='snowc_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snoavg) -! snow cover is multipled by 100 in SURFCE before writing it out - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval - if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. - end do - end do - -! snow depth in mm using nemsio - VarName='snod' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,si) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using nemsio - VarName='spfh2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qshltr) - if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - -! mid day avg albedo in fraction using nemsio -! VarName='albdosfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) -!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 -! enddo -! enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc_aveclm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='snoalb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc_avehcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc_avelcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc_avemcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdccnvcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m - VarName='cnwat' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cmc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - if (sm(i,j) /= 0.0) cmc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! frozen precip fraction using nemsio - VarName='cpofp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sr) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(sr(i,j) /= spval) then -!set range within (0,1) - sr(i,j)=min(1.,max(0.,sr(i,j))) - endif - enddo - enddo - -! sea ice skin temperature - VarName='tisfc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ti) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval - enddo - enddo - -! vegetation fraction in fraction. using nemsio - VarName='veg' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,vegfrc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) vegfrc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sh2o(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smc(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='soilt1' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,1)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval - !if (sm(i,j) /= 0.0) stc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='soilt2' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,2)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval - !if (sm(i,j) /= 0.0) stc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='soilt3' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,3)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval - !if (sm(i,j) /= 0.0) stc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='soilt4' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,stc(1,jsta_2l,4)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval - !if (sm(i,j) /= 0.0) stc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave - VarName='dlwrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwin) - -! inst incoming sfc longwave - VarName='dlwrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rlwin) - -! time averaged outgoing sfc longwave - VarName='ulwrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwout) -! inst outgoing sfc longwave - VarName='ulwrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,radot) - -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave - VarName='dswrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! inst incoming sfc shortwave - VarName='dswrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswin) - -! inst incoming clear sky sfc shortwave - VarName='csdlf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswinc) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! inst outgoing sfc shortwave using gfsio - VarName='uswrf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,rswout) - -! time averaged model top incoming shortwave - VarName='dswrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswintoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) - -! time averaged model top outgoing shortwave - VarName='uswrf_avetoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! inst surface sensible heat flux - VarName='shtfl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,twbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) - enddo - enddo - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! inst surface latent heat flux - VarName='lhtfl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,qwbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) - enddo - enddo - - if(me==0)print*,'rdaod= ',rdaod -! inst aod550 optical depth - if(rdaod) then - VarName='aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aod550) - - VarName='du_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,du_aod550) - - VarName='ss_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ss_aod550) - - VarName='su_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,su_aod550) - - VarName='oc_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,oc_aod550) - - VarName='bc_aod550' - call read_netcdf_2d_scatter(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,bc_aod550) - end if - -! time averaged ground heat flux using nemsio - VarName='gflux_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,subshx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! inst ground heat flux using nemsio - VarName='gflux' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,grnflx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval - enddo - enddo - -! time averaged zonal momentum flux using gfsio - VarName='uflx_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -! dong read in inst surface flux -! inst zonal momentum flux using gfsio -! VarName='uflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa) - -! inst meridional momentum flux using nemsio -! VarName='vflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa) - - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgpotevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - -! inst potential evaporation - VarName='pevpr' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,potevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval - enddo - enddo - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd10m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10) - - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - -! 10 m v using gfsio - VarName='vgrd10m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10) - - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vtype' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,buf) - VcoordName='sfc' - l=1 -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 !need to feed reasonable value to crtm - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability -! smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt -! sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index -! VarName='pres' -! VcoordName='convect-cld top' -! l=1 -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - VarName='prescnvclt' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptop) - - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='prescnvclb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres_avelct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres_avelcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp_avelct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres_avemct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres_avemcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp_avemct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres_avehct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres_avehcb' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp_avehct' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc_avebndcl' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function - VarName='cwork_aveclm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! accumulated total (base+surface) runoff - VarName='watr_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,runoff) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) runoff(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! retrieve shelter max temperature using nemsio - VarName='tmax_max2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxtshltr) - -! retrieve shelter min temperature using nemsio - VarName='tmin_min2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -! retrieve shelter max RH -! VarName='rh02max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr) - -! retrieve shelter min temperature using nemsio -! VarName='rh02min' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smcwlt) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smcwlt(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,suntime) - -! retrieve field capacity using nemsio - VarName='fldcp' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,fieldcapa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! retrieve time averaged surface visible beam downward solar flux - VarName='vbdsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisbeamswin) - VcoordName='sfc' - l=1 - -! retrieve time averaged surface visible diffuse downward solar flux - VarName='vddsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avisdiffswin) - -! retrieve time averaged surface near IR beam downward solar flux - VarName='nbdsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airbeamswin) - -! retrieve time averaged surface near IR diffuse downward solar flux - VarName='nddsf_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,airdiffswin) - -! retrieve time averaged surface clear sky outgoing LW - VarName='csulf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csulftoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwtoac) - -! retrieve time averaged surface clear sky outgoing SW - VarName='csusf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csusftoa' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswtoac) - -! retrieve time averaged surface clear sky incoming LW - VarName='csdlf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,alwinc) - -! retrieve time averaged surface clear sky incoming SW - VarName='csdsf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,aswinc) - -! retrieve shelter max specific humidity using nemsio - VarName='spfhmax_max2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxqshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', -! 1,maxqshltr(isa,jsa) - -! retrieve shelter min temperature using nemsio - VarName='spfhmin_min2m' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minqshltr) - -! retrieve storm runoff using nemsio - VarName='ssrun_acc' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,SSROFF) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) ssroff(i,j) = spval - enddo - enddo - -! retrieve direct soil evaporation - VarName='evbs_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgedir(i,j) = spval - enddo - enddo - -! retrieve CANOPY WATER EVAP - VarName='evcw_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgecan(i,j) = spval - enddo - enddo - -! retrieve PLANT TRANSPIRATION - VarName='trans_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgetrans) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgetrans(i,j) = spval - enddo - enddo - -! retrieve snow sublimation - VarName='sbsno_ave' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgesnow) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval - enddo - enddo - -! retrive total soil moisture - VarName='soilm' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,smstot) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smstot(i,j) = spval - enddo - enddo - -! retrieve snow phase change heat flux - VarName='snohf' - call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & - ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,snopcx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) snopcx(i,j) = spval - enddo - enddo - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! done with flux file, close it for now - Status=nf90_close(ncid2d) -! deallocate(tmp,recname,reclevtyp,reclev) - -! pos east -! call collect_loc(gdlat,dummy) -! if(me == 0)then -! latstart = nint(dummy(1,1)*gdsdegr) -! latlast = nint(dummy(im,jm)*gdsdegr) -! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& -! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) -! end if -! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me -! call collect_loc(gdlon,dummy) -! if(me == 0)then -! lonstart = nint(dummy(1,1)*gdsdegr) -! lonlast = nint(dummy(im,jm)*gdsdegr) -! end if -! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - -! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! - - RETURN - END - diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f b/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f deleted file mode 100644 index 624807426..000000000 --- a/sorc/ncep_post.fd/INITPOST_GFS_NETCDF_PARA.f +++ /dev/null @@ -1,2648 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST_GFS_NETCDF_PARA INITIALIZE POST FOR RUN -!! PRGRMMR: Wen Meng DATE: 2020-02-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2020-02-04 W Meng start from INITPOST_GFS_NETCDF.f -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_GFS_NETCDF_PARA -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_GFS_NETCDF_PARA(ncid3d) - - - use netcdf - use vrbls4d, only: dust, SALT, SUSO, SOOT, WASO, PP25, PP10 - use vrbls3d, only: t, q, uh, vh, pmid, pint, alpint, dpres, zint, zmid, o3, & - qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, & - tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, & - o3vdiff, o3prod, o3tndy, mwpv, unknown, vdiffzacce, zgdrag,cnvctummixing, & - vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, & - cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, & - wh, qqg, ref_10cm - use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & - cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, landfrac, radot, sigt4, & - cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & - islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & - bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & - rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, & - snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & - smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & - uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, tecan, tetran, tedir, twa, maxtshltr, & - mintshltr, maxrhshltr, fdnsst, & - minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & - cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & - maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & - up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & - avgedir,avgecan,paha,pahi,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & - avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & - alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550 - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice - use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & - eps => con_eps, epsm1 => con_epsm1 - use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa,pi - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, & - ttblq, rdpq, rdtheq, stheq, the0q, the0 - use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, & - ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, & - jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,& - ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & - jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & - nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER,rdaod - use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & - dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & - latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r - - use upp_physics, only: fpvsnew -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! type(nemsio_gfile) :: nfile,ffile,rfile - integer,parameter :: nvar2d=48 -! character(nemsio_charkind) :: name2d(nvar2d) - integer :: nvar3d, numDims -! character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) -! character(nemsio_charkind) :: varname,levtype -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" - -! integer,parameter:: MAXPTS=1000000 ! max im*jm points -! -! real,parameter:: con_g =9.80665e+0! gravity -! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O -! real,parameter:: con_rd =2.8705e+2 ! gas constant air -! real,parameter:: con_fvirt =con_rv/con_rd-1. -! real,parameter:: con_eps =con_rd/con_rv -! real,parameter:: con_epsm1 =con_rd/con_rv-1 -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - real, parameter :: gravi = 1.0/grav - character(len=20) :: VarName, VcoordName - integer :: Status, fldsize, fldst, recn, recn_vvel - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO,IOOMG,IOALL -! logical, parameter :: debugprint = .true., zerout = .false. - logical, parameter :: debugprint = .false., zerout = .false. - logical :: convert_rad_to_deg=.false. - CHARACTER*32 varcharval -! CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV,FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*255,ENVAR*50 - INTEGER IDATE(8),JDATE(8),JPDS(200),JGDS(200),KPDS(200),KGDS(200) -! LOGICAL*1 LB(IM,JM) -! -! INCLUDE COMMON BLOCKS. -! -! DECLARE VARIABLES. -! -! REAL fhour - integer nfhour ! forecast hour from nems io file - integer fhzero !bucket - real dtp !physics time step - REAL RINC(5) - - REAL DUMMY(IM,JM) -!jw - integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, & - I,J,L,ll,k,kf,irtn,igdout,n,Index,nframe, & - nframed2,iunitd3d,ierr,idum,iret,nrec,idrt - integer ncid3d,ncid2d,varid,nhcas - real TSTART,TLMH,TSPH,ES,FACT,soilayert,soilayerb,zhour,dum, & - tvll,pmll,tv, tx1, tx2 - - character*20,allocatable :: recname(:) - integer, allocatable :: reclev(:), kmsk(:,:) - real, allocatable :: glat1d(:), glon1d(:), qstl(:) - real, allocatable :: wrk1(:,:), wrk2(:,:) - real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & - qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) - real, dimension(lm+1) :: ak5, bk5 - real*8, allocatable :: pm2d(:,:), pi2d(:,:) - real, allocatable :: tmp(:) - real :: buf(im,jsta_2l:jend_2u) - real :: buf3d(im,jsta_2l:jend_2u,lm) - -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) - - real LAT - integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass - - integer, parameter :: npass2=5, npass3=30 - real, parameter :: third=1.0/3.0 - INTEGER, DIMENSION(2) :: ij4min, ij4max - REAL :: omgmin, omgmax - real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:) - REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:) - real, allocatable :: div3d(:,:,:) - real(kind=4),allocatable :: vcrd(:,:) - real :: dum_const - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NETCDF_PARA' - WRITE(6,*)'me=',me, & - 'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im -! - isa = im / 2 - jsa = (jsta+jend) / 2 - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - buf(i,j) = spval - enddo - enddo - - Status=nf90_get_att(ncid3d,nf90_global,'ak',ak5) - if(Status/=0)then - print*,'ak not found; assigning missing value' - ak5=spval - else - if(me==0)print*,'ak5= ',ak5 - end if - Status=nf90_get_att(ncid3d,nf90_global,'idrt',idrt) - if(Status/=0)then - print*,'idrt not in netcdf file,reading grid' - Status=nf90_get_att(ncid3d,nf90_global,'grid',varcharval) - if(Status/=0)then - print*,'idrt and grid not in netcdf file, set default to latlon' - idrt=0 - MAPTYPE=0 - else - if(trim(varcharval)=='rotated_latlon')then - MAPTYPE=207 - idrt=207 - Status=nf90_get_att(ncid3d,nf90_global,'cen_lon',dum_const) - if(Status/=0)then - print*,'cen_lon not found; assigning missing value' - cenlon=spval - else - if(dum_const<0.)then - cenlon=nint((dum_const+360.)*gdsdegr) - else - cenlon=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'cen_lat',dum_const) - if(Status/=0)then - print*,'cen_lat not found; assigning missing value' - cenlat=spval - else - cenlat=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart_r not found; assigning missing value' - lonstart_r=spval - else - if(dum_const<0.)then - lonstart_r=nint((dum_const+360.)*gdsdegr) - else - lonstart_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart_r not found; assigning missing value' - latstart_r=spval - else - latstart_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast_r not found; assigning missing value' - lonlast_r=spval - else - if(dum_const<0.)then - lonlast_r=nint((dum_const+360.)*gdsdegr) - else - lonlast_r=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast_r not found; assigning missing value' - latlast_r=spval - else - latlast_r=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & - lonstart,latstart,cenlon,cenlat,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) start - else if(trim(varcharval)=='latlon')then - MAPTYPE=0 - idrt=0 - - Status=nf90_get_att(ncid3d,nf90_global,'lon1',dum_const) - if(Status/=0)then - print*,'lonstart not found; assigning missing value' - lonstart=spval - else - if(dum_const<0.)then - lonstart=nint((dum_const+360.)*gdsdegr) - else - lonstart=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat1',dum_const) - if(Status/=0)then - print*,'latstart not found; assigning missing value' - latstart=spval - else - latstart=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'lon2',dum_const) - if(Status/=0)then - print*,'lonlast not found; assigning missing value' - lonlast=spval - else - if(dum_const<0.)then - lonlast=nint((dum_const+360.)*gdsdegr) - else - lonlast=dum_const*gdsdegr - end if - end if - Status=nf90_get_att(ncid3d,nf90_global,'lat2',dum_const) - if(Status/=0)then - print*,'latlast not found; assigning missing value' - latlast=spval - else - latlast=dum_const*gdsdegr - end if - - Status=nf90_get_att(ncid3d,nf90_global,'dlon',dum_const) - if(Status/=0)then - print*,'dlmd not found; assigning missing value' - dxval=spval - else - dxval=dum_const*gdsdegr - end if - Status=nf90_get_att(ncid3d,nf90_global,'dlat',dum_const) - if(Status/=0)then - print*,'dphd not found; assigning missing value' - dyval=spval - else - dyval=dum_const*gdsdegr - end if - - print*,'lonstart,latstart,dyval,dxval', & - lonstart,lonlast,latstart,latlast,dyval,dxval - -! Jili Dong add support for regular lat lon (2019/03/22) end - - else if(trim(varcharval)=='gaussian')then - MAPTYPE=4 - idrt=4 - else ! setting default maptype - MAPTYPE=0 - idrt=0 - end if - end if !end reading grid - end if !end reading idrt - if(me==0)print*,'idrt MAPTYPE= ',idrt,MAPTYPE -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! LMH and LMV always = LM for sigma-type vert coord - -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i = 1, im - LMV(i,j) = lm - LMH(i,j) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - -!$omp parallel do private(i,j,l) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM (i,j,l) = 1.0 - VTM (i,j,l) = 1.0 - end do - end do - end do - - Status=nf90_get_att(ncid3d,nf90_global,'nhcas',nhcas) - if(Status/=0)then - print*,'nhcas not in netcdf file, set default to nonhydro' - nhcas=0 - end if - if(me==0)print*,'nhcas= ',nhcas - if (nhcas == 0 ) then !non-hydrostatic case - nrec=15 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','spfh','tmp','o3mr', & - 'presnh','dzdt', 'clwmr','dpres', & - 'delz','icmr','rwmr', & - 'snmr','grle','cld_amt'] - else - nrec=8 - allocate (recname(nrec)) - recname=[character(len=20) :: 'ugrd','vgrd','tmp','spfh','o3mr', & - 'hypres', 'clwmr','dpres'] - endif - -! write(0,*)'nrec=',nrec - !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) - -! hardwire idate for now -! idate=(/2017,08,07,00,0,0,0,0/) -! get cycle start time - Status=nf90_inq_varid(ncid3d,'time',varid) - if(Status/=0)then - print*,'time not in netcdf file, stopping' - STOP 1 - else - Status=nf90_get_att(ncid3d,varid,'units',varcharval) - if(Status/=0)then - print*,'time unit not available' - else - print*,'time unit read from netcdf file= ',varcharval -! assume use hours as unit -! idate_loc=index(varcharval,'since')+6 - read(varcharval,101)idate(1),idate(2),idate(3),idate(4),idate(5) - end if -! Status=nf90_inquire_dimension(ncid3d,varid,len=ntimes) -! allocate(fhours(ntimes)) -! status = nf90_inq_varid(ncid3d,varid,fhours) -! Status=nf90_get_var(ncid3d,varid,nfhour,start=(/1/), & -! count=(/1/)) -! if(Status/=0)then -! print*,'forecast hour not in netcdf file, stopping' -! STOP 1 -! end if - end if - 101 format(T13,i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'idate= ',idate(1:5) -! get longitude - Status=nf90_inq_varid(ncid3d,'grid_xt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlon ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glon1d) - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(glon1d(i),kind=4) - end do - end do - lonstart = nint(glon1d(1)*gdsdegr) - lonlast = nint(glon1d(im)*gdsdegr) - dxval = nint(abs(glon1d(1)-glon1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. - if(convert_rad_to_deg)then - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi - end do - end do - else - do j=jsta,jend - do i=1,im - gdlon(i,j) = real(dummy(i,j),kind=4) - end do - end do - end if - if(convert_rad_to_deg)then - lonstart = nint(dummy(1,1)*gdsdegr)*180./pi - lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr)*180./pi - else - lonstart = nint(dummy(1,1)*gdsdegr) - lonlast = nint(dummy(im,jm)*gdsdegr) - dxval = nint(abs(dummy(1,1)-dummy(2,1))*gdsdegr) - end if - -! Jili Dong add support for regular lat lon (2019/03/22) start - if (MAPTYPE == 0) then - if(lonstart<0.)then - lonstart=lonstart+360.*gdsdegr - end if - if(lonlast<0.)then - lonlast=lonlast+360.*gdsdegr - end if - end if -! Jili Dong add support for regular lat lon (2019/03/22) end - - end if - print*,'lonstart,lonlast,dxval ',lonstart,lonlast,dxval -! get latitude - Status=nf90_inq_varid(ncid3d,'grid_yt',varid) - Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(debugprint)print*,'number of dim for gdlat ',numDims - if(numDims==1)then - Status=nf90_get_var(ncid3d,varid,glat1d) - do j=jsta,jend - do i=1,im - gdlat(i,j) = real(glat1d(j),kind=4) - end do - end do - latstart = nint(glat1d(1)*gdsdegr) - latlast = nint(glat1d(jm)*gdsdegr) - dyval = nint(abs(glat1d(1)-glat1d(2))*gdsdegr) - else if(numDims==2)then - Status=nf90_get_var(ncid3d,varid,dummy) - if(maxval(abs(dummy))1000.)print*,'bad T ',t(i,j,l) - enddo - enddo - enddo - call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, & - spval,recname(11),qqi(1,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, & - spval,recname(12),qqr(1,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, & - spval,recname(13),qqs(1,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, & - spval,recname(14),qqg(1,jsta_2l,1),lm) - call read_netcdf_3d_para(ncid3d,im,jm,jsta,jsta_2l,jend,jend_2u, & - spval,recname(15),cfr(1,jsta_2l,1),lm) - -! calculate CWM from FV3 output - do l=1,lm - do j=jsta,jend - do i=1,im - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) - enddo - enddo - if(debugprint)print*,'sample l,t,q,u,v,w,= ',isa,jsa,l & - ,t(isa,jsa,l),q(isa,jsa,l),uh(isa,jsa,l),vh(isa,jsa,l) & - ,wh(isa,jsa,l) - if(debugprint)print*,'sample l cwm for FV3',l, & - cwm(isa,jsa,l) - end do - -! surface pressure - VarName='pressfc' - call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pint(1,jsta_2l,lp1)) - do j=jsta,jend - do i=1,im -! if(pint(i,j,lp1)>1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & -! print*,'bad psfc ',i,j,pint(i,j,lp1) - end do - end do - if(debugprint)print*,'sample ',VarName,' =',pint(isa,jsa,lp1) - - pt = ak5(1) - - do j=jsta,jend - do i=1,im - pint(i,j,1)= pt - end do - end do - - do l=2,lp1 - do j=jsta,jend - do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo -! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l & -! ,pint(ii,jj,l),pmid(ii,jj,l) - end do - -!compute pmid from averaged two layer pint - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) - enddo - enddo - enddo - -! surface height from FV3 -! dong set missing value for zint -! zint=spval - VarName='hgtsfc' - call read_netcdf_2d_para(ncid3d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,zint(1,jsta_2l,lp1)) - if(debugprint)print*,'sample ',VarName,' =',zint(isa,jsa,lp1) - do j=jsta,jend - do i=1,im - if (zint(i,j,lp1) /= spval) then - fis(i,j) = zint(i,j,lp1) * grav - else - fis(i,j) = spval - endif - enddo - enddo - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. buf3d(i,j,l)/=spval)then -!make sure delz is positive - zint(i,j,l)=zint(i,j,l+1)+abs(buf3d(i,j,l)) -! if(zint(i,j,l)>1.0E6)print*,'bad H ',i,j,l,zint(i,j,l) - else - zint(i,j,l)=spval - end if - end do - end do - print*,'sample zint= ',isa,jsa,l,zint(isa,jsa,l) - end do - - do l=lp1,1,-1 - do j=jsta,jend - do i=1,im - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do - - do l=lm,1,-1 - do j=jsta,jend - do i=1,im - if(zint(i,j,l+1)/=spval .and. zint(i,j,l)/=spval & - .and. pmid(i,j,l)/=spval)then - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - if(zmid(i,j,l)>1.0E6)print*,'bad Hmid ',i,j,l,zmid(i,j,l) - else - zmid(i,j,l)=spval - endif - end do - end do - end do - - - pt = ak5(1) - -! - - deallocate (vcoord4) -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! - -! done with 3d file, close it for now - Status=nf90_close(ncid3d) - deallocate(recname) - -! open flux file - Status = nf90_open(trim(fileNameFlux),ior(nf90_nowrite, nf90_mpiio), & - ncid2d,comm=mpi_comm_world,info=mpi_info_null) - if ( Status /= 0 ) then - print*,'error opening ',fileNameFlux, ' Status = ', Status - print*,'skip reading of flux file' - endif - -! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD - VarName='IVEGSRC' - Status=nf90_get_att(ncid2d,nf90_global,'IVEGSRC',IVEGSRC) - if (Status /= 0) then - print*,VarName,' not found-Assigned 1 for IGBP as default' - IVEGSRC=1 - end if - if (me == 0) print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==2)then - novegtype=13 - else if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - if (me == 0) print*,'novegtype= ',novegtype - - Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) - if (Status /= 0) then - print*,VarName,' not found-Assigned 11 GFDL as default' - imp_physics=11 - end if - if (me == 0) print*,'MP_PHYSICS= ',imp_physics -! - Status=nf90_get_att(ncid2d,nf90_global,'fhzero',fhzero) - if (Status /= 0) then - print*,VarName,' not found-Assigned 3 hours as default' - fhzero=3 - end if - if (me == 0) print*,'fhzero= ',fhzero -! - Status=nf90_get_att(ncid2d,nf90_global,'dtp',dtp) - if (Status /= 0) then - print*,VarName,' not found-Assigned 90s as default' - dtp=90 - end if - if (me == 0) print*,'dtp= ',dtp -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then - CALL MICROINIT(imp_physics) - end if - - tprec = float(fhzero) - if(ifhr>240)tprec=12. - tclod = tprec - trdlw = tprec - trdsw = tprec - tsrfc = tprec - tmaxmin = tprec - td3d = tprec - print*,'tprec = ',tprec - - -!Set REF_10CM as missning since gfs doesn't ouput it - do l=1,lm - do j=jsta,jend - do i=1,im - REF_10CM(i,j,l)=spval - enddo - enddo - enddo - - VarName='land' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sm) - if(debugprint)print*,'sample ',VarName,' =',sm(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j) - enddo - enddo - -! sea ice mask - - VarName = 'icec' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sice) - if(debugprint)print*,'sample ',VarName,' = ',sice(isa,jsa) - -! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea -! mask=0 -! GFS flux files have land points with non-zero sea ice, per Iredell, -! these -! points have sea ice changed to zero, i.e., trust land mask more than -! sea ice -! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0 - enddo - enddo - - -! PBL height using nemsio - VarName = 'hpbl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pblh) - if(debugprint)print*,'sample ',VarName,' = ',pblh(isa,jsa) - -! frictional velocity using nemsio - VarName='fricv' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ustar) -! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa) - -! roughness length using getgb - VarName='sfcr' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,z0) -! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa) - -! sfc exchange coeff - VarName='sfexc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,SFCEXC) - -! aerodynamic conductance - VarName='acond' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,acond) - if(debugprint)print*,'sample ',VarName,' = ',acond(isa,jsa) - -! mid day avg albedo - VarName='albdo_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgalbedo) - if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - do j=jsta,jend - do i=1,im - if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 - enddo - enddo - -! surface potential T using getgb - VarName='tmpsfc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ths) - -! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (ths(i,j) /= spval) then -! write(0,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1) - ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa - endif - QS(i,j) = SPVAL ! GFS does not have surface specific humidity - twbs(i,j) = SPVAL ! GFS does not have inst sensible heat flux - qwbs(i,j) = SPVAL ! GFS does not have inst latent heat flux -!assign sst - if (sm(i,j) /= 0.0) then - sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa - else - sst(i,j) = spval - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa) - -! foundation temperature - VarName='tref' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,fdnsst) - if(debugprint)print*,'sample ',VarName,' = ',fdnsst(isa,jsa) - -! GFS does not have time step and physics time step, make up ones since they -! are not really used anyway -! NPHS=1. -! DT=90. -! DTQ2 = DT * NPHS !MEB need to get physics DT - DTQ2 = DTP !MEB need to get physics DT - NPHS=1 - DT = DTQ2/NPHS !MEB need to get DT - TSPH = 3600./DT - -! convective precip in m per physics time step using getgb -! read 3 hour bucket - VarName='cpratb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcprate) -! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! read continuous bucket - VarName='cprat_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcprate_cont) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = & - avgcprate_cont(i,j) * (dtq2*0.001) - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgcprate_cont(isa,jsa) - -! print*,'maxval CPRATE: ', maxval(CPRATE) - -! precip rate in m per physics time step using getgb - VarName='prateb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgprec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(avgprec(i,j) /= spval)avgprec(i,j)=avgprec(i,j)*(dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa) - -! prec = avgprec !set avg cprate to inst one to derive other fields - - VarName='prate_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgprec_cont) -! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgprec_cont(i,j) /=spval)avgprec_cont(i,j)=avgprec_cont(i,j) & - * (dtq2*0.001) - enddo - enddo - - if(debugprint)print*,'sample ',VarName,' = ',avgprec_cont(isa,jsa) -! precip rate in m per physics time step - VarName='tprcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,prec) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (prec(i,j) /= spval) prec(i,j)=prec(i,j)* (dtq2*0.001) & - * 1000. / dtp - enddo - enddo - -! convective precip rate in m per physics time step - VarName='cnvprcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cprate) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cprate(i,j) /= spval) then - cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) & - * 1000. / dtp - else - cprate(i,j) = 0. - endif - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',cprate(isa,jsa) - -! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f - -! max hourly 1-km agl reflectivity -! VarName='refdmax' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refd_max) -! if(debugprint)print*,'sample ',VarName,' = ',refd_max(isa,jsa) -! max hourly -10C reflectivity -! VarName='refdmax263k' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,refdm10c_max) -! if(debugprint)print*,'sample ',VarName,' = ',refdm10c_max(isa,jsa) - -! max hourly u comp of 10m agl wind -! VarName='u10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,u10max) -! if(debugprint)print*,'sample ',VarName,' = ',u10max(isa,jsa) -! max hourly v comp of 10m agl wind -! VarName='v10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,v10max) -! if(debugprint)print*,'sample ',VarName,' = ',v10max(isa,jsa) -! max hourly 10m agl wind speed -! VarName='spd10max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,wspd10max) -! if(debugprint)print*,'sample ',VarName,' = ',wspd10max(isa,jsa) - - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! inst snow water eqivalent using nemsio - VarName='weasd' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sno) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa) - -! ave snow cover - VarName='snowc_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,snoavg) -! snow cover is multipled by 100 in SURFCE before writing it out - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval - if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100. - end do - end do - -! snow depth in mm using nemsio - VarName='snod' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,si) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval - if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 - CLDEFI(i,j) = SPVAL ! GFS does not have convective cloud efficiency - lspa(i,j) = spval ! GFS does not have similated precip - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - TH10(i,j) = SPVAL ! GFS does not have 10 m theta - Q10(i,j) = SPVAL ! GFS does not have 10 m humidity - ALBASE(i,j) = SPVAL ! GFS does not have snow free albedo - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa) - -! 2m T using nemsio - VarName='tmp2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tshltr) - if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa) - -! GFS does not have 2m pres, estimate it, also convert t to theta - Do j=jsta,jend - Do i=1,im - PSHLTR(I,J)=pint(I,J,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/PSHLTR(I,J))**CAPA ! convert to theta -! if (j == jm/2 .and. mod(i,50) == 0) -! + print*,'sample 2m T and P after scatter= ' -! + ,i,j,tshltr(i,j),pshltr(i,j) - end do - end do - -! 2m specific humidity using nemsio - VarName='spfh2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,qshltr) - if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa) - -! mid day avg albedo in fraction using nemsio -! VarName='albdosfc' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,avgalbedo) -!! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction -!!$omp parallel do private(i,j) -! do j=jsta,jend -! do i=1,im -! if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01 -! enddo -! enddo -! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa) - -! time averaged column cloud fractionusing nemsio - VarName='tcdc_aveclm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgtcdc) -! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa) - -! GFS probably does not use zenith angle -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - Czen(i,j) = spval - CZMEAN(i,j) = SPVAL - enddo - enddo - -! maximum snow albedo in fraction using nemsio - VarName='snoalb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,mxsnal) -! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa) - -! land fraction - VarName='lfrac' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,landfrac) - -! GFS probably does not use sigt4, set it to sig*t^4 -!$omp parallel do private(i,j,tlmh) - Do j=jsta,jend - Do i=1,im - TLMH = T(I,J,LM) * T(I,J,LM) - Sigt4(i,j) = 5.67E-8 * TLMH * TLMH - End do - End do - -! TG is not used, skip it for now - -! GFS does not have inst cloud fraction for high, middle, and low cloud -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - cfrach(i,j) = spval - cfracl(i,j) = spval - cfracm(i,j) = spval - enddo - enddo - -! ave high cloud fraction using nemsio - VarName='tcdc_avehcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcfrach) -! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa) - -! ave low cloud fraction using nemsio - VarName='tcdc_avelcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcfracl) -! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa) - -! ave middle cloud fraction using nemsio - VarName='tcdc_avemcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgcfracm) -! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01 - enddo - enddo - if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa) - -! inst convective cloud fraction using nemsio - VarName='tcdccnvcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cnvcfr) -! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cnvcfr(i,j) /= spval) cnvcfr (i,j)= cnvcfr(i,j) * 0.01 - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa) - -! slope type using nemsio - VarName='sltyp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - islope(i,j) = nint(buf(i,j)) - else - islope(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa) - -! plant canopy sfc wtr in m - VarName='cnwat' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cmc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001 - if (sm(i,j) /= 0.0) cmc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - grnflx(i,j) = spval ! GFS does not have inst ground heat flux - enddo - enddo - -! frozen precip fraction using nemsio - VarName='cpofp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sr) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if(sr(i,j) /= spval) then -!set range within (0,1) - sr(i,j)=min(1.,max(0.,sr(i,j))) - endif - enddo - enddo - -! sea ice skin temperature - VarName='tisfc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ti) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval - enddo - enddo - -! vegetation fraction in fraction. using nemsio - VarName='veg' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,vegfrc) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (vegfrc(i,j) /= spval) then - vegfrc(i,j) = vegfrc(i,j) * 0.01 - else - vegfrc(i,j) = 0.0 - endif - enddo - enddo -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) vegfrc(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa) - -! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam - - SLDPTH(1) = 0.10 - SLDPTH(2) = 0.3 - SLDPTH(3) = 0.6 - SLDPTH(4) = 1.0 - -! liquid volumetric soil mpisture in fraction using nemsio - VarName='soill1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1) - - VarName='soill2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2) - - VarName='soill3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3) - - VarName='soill4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sh2o(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4) - -! volumetric soil moisture using nemsio - VarName='soilw1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,1)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1) - - VarName='soilw2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,2)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2) - - VarName='soilw3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,3)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3) - - VarName='soilw4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smc(1,jsta_2l,4)) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4) - -! soil temperature using nemsio - VarName='soilt1' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,1)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval - !if (sm(i,j) /= 0.0) stc(i,j,1) = spval - enddo - enddo - if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1) - - VarName='soilt2' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,2)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval - !if (sm(i,j) /= 0.0) stc(i,j,2) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2) - - VarName='soilt3' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,3)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval - !if (sm(i,j) /= 0.0) stc(i,j,3) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3) - - VarName='soilt4' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,stc(1,jsta_2l,4)) -! mask open water areas, combine with sea ice tmp -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval - !if (sm(i,j) /= 0.0) stc(i,j,4) = spval - enddo - enddo - if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4) - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1 - ncfrcv(i,j) = 1.0 - acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1 - ncfrst(i,j) = 1.0 - bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF - rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave - enddo - enddo -! trdlw(i,j) = 6.0 - ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1 - -! time averaged incoming sfc longwave - VarName='dlwrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwin) - -! inst incoming sfc longwave - VarName='dlwrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rlwin) - -! time averaged outgoing sfc longwave - VarName='ulwrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwout) -! inst outgoing sfc longwave - VarName='ulwrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,radot) - -! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa) - -! time averaged outgoing model top longwave using gfsio - VarName='ulwrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa) - -! GFS incoming sfc longwave has been averaged, set ARDLW to 1 - ardsw=1.0 -! trdsw=6.0 - -! time averaged incoming sfc shortwave - VarName='dswrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswin) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa) - -! inst incoming sfc shortwave - VarName='dswrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rswin) - -! inst incoming clear sky sfc shortwave - VarName='csdlf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rswinc) - -! time averaged incoming sfc uv-b using getgb - VarName='duvb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,auvbin) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa) - -! time averaged incoming sfc clear sky uv-b using getgb - VarName='cduvb_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,auvbinc) -! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa) - -! time averaged outgoing sfc shortwave using gfsio - VarName='uswrf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswout) -! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa) - -! inst outgoing sfc shortwave using gfsio - VarName='uswrf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,rswout) - -! time averaged model top incoming shortwave - VarName='dswrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswintoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa) - -! time averaged model top outgoing shortwave - VarName='uswrf_avetoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswtoa) -! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa) - -! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux -! has reversed sign convention using gfsio - VarName='shtfl_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfcshx) -! where (sfcshx /= spval)sfcshx=-sfcshx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa) - -! inst surface sensible heat flux - VarName='shtfl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,twbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j) - enddo - enddo - -! GFS surface flux has been averaged, set ASRFC to 1 - asrfc=1.0 -! tsrfc=6.0 - -! time averaged surface latent heat flux, multiplied by -1 because wrf model flux -! has reversed sign vonvention using gfsio - VarName='lhtfl_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfclhx) -! where (sfclhx /= spval)sfclhx=-sfclhx -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j) - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa) - -! inst surface latent heat flux - VarName='lhtfl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,qwbs) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j) - enddo - enddo - - if(me==0)print*,'rdaod= ',rdaod -! inst aod550 optical depth - if(rdaod) then - VarName='aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aod550) - - VarName='du_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,du_aod550) - - VarName='ss_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ss_aod550) - - VarName='su_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,su_aod550) - - VarName='oc_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,oc_aod550) - - VarName='bc_aod550' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,bc_aod550) - endif !end if rdaod - - -! time averaged ground heat flux using nemsio - VarName='gflux_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,subshx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa) - -! inst ground heat flux using nemsio - VarName='gflux' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,grnflx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval - enddo - enddo - -! time averaged zonal momentum flux using gfsio - VarName='uflx_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfcux) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa) - -! time averaged meridional momentum flux using nemsio - VarName='vflx_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,sfcvx) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa) - -! dong read in inst surface flux -! inst zonal momentum flux using gfsio -! VarName='uflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcuxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcuxi(isa,jsa) - -! inst meridional momentum flux using nemsio -! VarName='vflx' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,sfcvxi) -! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvxi(isa,jsa) - - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - sfcuvx(i,j) = spval ! GFS does not use total momentum flux - enddo - enddo - -! time averaged zonal gravity wave stress using nemsio - VarName='u-gwd_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,gtaux) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa) - -! time averaged meridional gravity wave stress using getgb - VarName='v-gwd_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,gtauy) -! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa) - -! time averaged accumulated potential evaporation - VarName='pevpr_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgpotevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa) - -! inst potential evaporation - VarName='pevpr' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,potevp) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval - enddo - enddo - - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im -! GFS does not have temperature tendency due to long wave radiation - rlwtt(i,j,l) = spval -! GFS does not have temperature tendency due to short wave radiation - rswtt(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from convection - tcucn(i,j,l) = spval - tcucns(i,j,l) = spval -! GFS does not have temperature tendency due to latent heating from grid scale - train(i,j,l) = spval - enddo - enddo - enddo - -! set avrain to 1 - avrain=1.0 - avcnvc=1.0 - theat=6.0 ! just in case GFS decides to output T tendency - -! 10 m u using nemsio - VarName='ugrd10m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,u10) - - do j=jsta,jend - do i=1,im - u10h(i,j)=u10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa) - -! 10 m v using gfsio - VarName='vgrd10m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,v10) - - do j=jsta,jend - do i=1,im - v10h(i,j)=v10(i,j) - end do - end do -! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa) - -! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='vtype' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) -! where (buf /= spval) -! ivgtyp=nint(buf) -! elsewhere -! ivgtyp=0 !need to feed reasonable value to crtm -! end where -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - ivgtyp(i,j) = nint(buf(i,j)) - else - ivgtyp(i,j) = 0 - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa) - -! soil type, it's in GFS surface file, hopefully will merge into gfsio soon - VarName='sotyp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (buf(i,j) < spval) then - isltyp(i,j) = nint(buf(i,j)) - else - isltyp(i,j) = 0 !need to feed reasonable value to crtm - endif - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - smstav(i,j) = spval ! GFS does not have soil moisture availability -! smstot(i,j) = spval ! GFS does not have total soil moisture - sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation - acsnow(i,j) = spval ! GFS does not have averaged accumulated snow - acsnom(i,j) = spval ! GFS does not have snow melt -! sst(i,j) = spval ! GFS does not have sst???? - thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute - qz0(i,j) = spval ! GFS does not output humidity at roughness length - uz0(i,j) = spval ! GFS does not output u at roughness length - vz0(i,j) = spval ! GFS does not output humidity at roughness length - enddo - enddo - do l=1,lm -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - EL_PBL(i,j,l) = spval ! GFS does not have mixing length - exch_h(i,j,l) = spval ! GFS does not output exchange coefficient - enddo - enddo - enddo -! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa) - -! retrieve inst convective cloud top, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index -! VarName='pres' -! VcoordName='convect-cld top' -! l=1 -! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa) - VarName='prescnvclt' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptop) - - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - htop(i,j) = spval - if(ptop(i,j) <= 0.0) ptop(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im - if(ptop(i,j) < spval)then - do l=1,lm - if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l -! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', & -! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j) - exit - end if - end do - end if - end do - end do - -! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index, -! will need to modify CLDRAD.f to use pressure directly instead of index - VarName='prescnvclb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pbot) -! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa) -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - hbot(i,j) = spval - if(pbot(i,j) <= 0.0) pbot(i,j) = spval - enddo - enddo - do j=jsta,jend - do i=1,im -! if(.not.lb(i,j))print*,'false bitmask for pbot at ' -! + ,i,j,pbot(i,j) - if(pbot(i,j) < spval)then - do l=lm,1,-1 - if(pbot(i,j) >= pmid(i,j,l)) then - hbot(i,j) = l -! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', & -! pbot(i,j),pmid(i,j,l),hbot(i,j) - exit - end if - end do - end if - end do - end do - if(debugprint)print*,'sample hbot = ',hbot(isa,jsa) -! retrieve time averaged low cloud top pressure using nemsio - VarName='pres_avelct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptopl) -! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa) - -! retrieve time averaged low cloud bottom pressure using nemsio - VarName='pres_avelcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pbotl) -! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa) - -! retrieve time averaged low cloud top temperature using nemsio - VarName='tmp_avelct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,Ttopl) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa) - -! retrieve time averaged middle cloud top pressure using nemsio - VarName='pres_avemct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa) - -! retrieve time averaged middle cloud bottom pressure using nemsio - VarName='pres_avemcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pbotm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa) - -! retrieve time averaged middle cloud top temperature using nemsio - VarName='tmp_avemct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,Ttopm) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa) - -! retrieve time averaged high cloud top pressure using nemsio ********* - VarName='pres_avehct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,ptoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa) - -! retrieve time averaged high cloud bottom pressure using nemsio - VarName='pres_avehcb' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pboth) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa) - -! retrieve time averaged high cloud top temperature using nemsio - VarName='tmp_avehct' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,Ttoph) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa) - -! retrieve boundary layer cloud cover using nemsio - VarName='tcdc_avebndcl' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pblcfr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa) -! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction -!$omp parallel do private(i,j) - do j = jsta_2l, jend_2u - do i=1,im - if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01 - enddo - enddo - -! retrieve cloud work function - VarName='cwork_aveclm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,cldwork) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa) - -! accumulated total (base+surface) runoff - VarName='watr_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,runoff) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) runoff(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa) - -! accumulated evaporation of intercepted water - VarName='ecan_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) tecan(i,j) = spval - enddo - enddo - -! accumulated plant transpiration - VarName='etran_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tetran) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) tetran(i,j) = spval - enddo - enddo - -! accumulated soil surface evaporation - VarName='edir_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,tedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) tedir(i,j) = spval - enddo - enddo - -! total water storage in aquifer - VarName='wa_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,twa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) twa(i,j) = spval - enddo - enddo - -! retrieve shelter max temperature using nemsio - VarName='tmax_max2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,maxtshltr) - -! retrieve shelter min temperature using nemsio - VarName='tmin_min2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,mintshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -! retrieve shelter max RH -! VarName='rh02max' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,maxrhshltr) - -! retrieve shelter min temperature using nemsio -! VarName='rh02min' -! call read_netcdf_2d_scatter(me,ncid2d,1,im,jm,jsta,jsta_2l & -! ,jend_2u,MPI_COMM_COMP,icnt,idsp,spval,VarName,minrhshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', & -! 1,mintshltr(im/2,(jsta+jend)/2) - -!$omp parallel do private(i,j) - do j=jsta_2l,jend_2u - do i=1,im - MAXRHSHLTR(i,j) = SPVAL - MINRHSHLTR(i,j) = SPVAL - enddo - enddo - -! retrieve ice thickness using nemsio - VarName='icetk' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,dzice) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa) - -! retrieve wilting point using nemsio - VarName='wilt' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smcwlt) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smcwlt(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa) - -! retrieve sunshine duration using nemsio - VarName='sunsd_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,suntime) - -! retrieve field capacity using nemsio - VarName='fldcp' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,fieldcapa) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval - enddo - enddo -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa) - -! retrieve time averaged surface visible beam downward solar flux - VarName='vbdsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avisbeamswin) - l=1 - -! retrieve time averaged surface visible diffuse downward solar flux - VarName='vddsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avisdiffswin) - -! retrieve time averaged surface near IR beam downward solar flux - VarName='nbdsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,airbeamswin) - -! retrieve time averaged surface near IR diffuse downward solar flux - VarName='nddsf_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,airdiffswin) - -! retrieve time averaged surface clear sky outgoing LW - VarName='csulf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csulftoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwtoac) - -! retrieve time averaged surface clear sky outgoing SW - VarName='csusf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswoutc) - -! retrieve time averaged TOA clear sky outgoing LW - VarName='csusftoa' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswtoac) - -! retrieve time averaged surface clear sky incoming LW - VarName='csdlf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,alwinc) - -! retrieve time averaged surface clear sky incoming SW - VarName='csdsf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,aswinc) - -! retrieve shelter max specific humidity using nemsio - VarName='spfhmax_max2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,maxqshltr) -! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', -! 1,maxqshltr(isa,jsa) - -! retrieve shelter min temperature using nemsio - VarName='spfhmin_min2m' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,minqshltr) - -! retrieve storm runoff using nemsio - VarName='ssrun_acc' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,SSROFF) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) ssroff(i,j) = spval - enddo - enddo - -! retrieve direct soil evaporation - VarName='evbs_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgedir) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgedir(i,j) = spval - enddo - enddo - -! retrieve CANOPY WATER EVAP - VarName='evcw_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgecan) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgecan(i,j) = spval - enddo - enddo - -! retrieve AVERAGED PRECIP ADVECTED HEAT FLUX - VarName='pah_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,paha) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) paha(i,j) = spval - enddo - enddo - -! retrieve nstantaneous PRECIP ADVECTED HEAT FLUX - VarName='pahi' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,pahi) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) pahi(i,j) = spval - enddo - enddo - -! retrieve PLANT TRANSPIRATION - VarName='trans_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgetrans) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) avgetrans(i,j) = spval - enddo - enddo - -! retrieve snow sublimation - VarName='sbsno_ave' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,avgesnow) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval - enddo - enddo - -! retrive total soil moisture - VarName='soilm' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,smstot) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) smstot(i,j) = spval - enddo - enddo - -! retrieve snow phase change heat flux - VarName='snohf' - call read_netcdf_2d_para(ncid2d,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,snopcx) -! mask water areas -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - if (sm(i,j) /= 0.0) snopcx(i,j) = spval - enddo - enddo - -! GFS does not have deep convective cloud top and bottom fields - -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - HTOPD(i,j) = SPVAL - HBOTD(i,j) = SPVAL - HTOPS(i,j) = SPVAL - HBOTS(i,j) = SPVAL - CUPPT(i,j) = SPVAL - enddo - enddo - -! done with flux file, close it for now - Status=nf90_close(ncid2d) -! deallocate(tmp,recname,reclevtyp,reclev) - -! pos east -! call collect_loc(gdlat,dummy) -! if(me == 0)then -! latstart = nint(dummy(1,1)*gdsdegr) -! latlast = nint(dummy(im,jm)*gdsdegr) -! print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,& -! 'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1) -! end if -! call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me -! call collect_loc(gdlon,dummy) -! if(me == 0)then -! lonstart = nint(dummy(1,1)*gdsdegr) -! lonlast = nint(dummy(im,jm)*gdsdegr) -! end if -! call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) -! call mpi_bcast(lonlast, 1,MPI_INTEGER,0,mpi_comm_comp,irtn) - -! write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast -! - -! generate look up table for lifted parcel calculations - - THL = 210. - PLQ = 70000. - pt_TBL = 10000. ! this is for 100 hPa added by Moorthi - - CALL TABLE(PTBL,TTBL,PT_TBL, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME == 0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -!$omp parallel do private(l) - DO L = 1,LSM - ALSL(L) = LOG(SPL(L)) - END DO -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me == 0)then - print*,'writing out igds' - igdout = 110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - if(maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)TRUELAT2 !Assume projection at +-90 - WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3) THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast - WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE == 0 .OR. MAPTYPE == 203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - end if -! -! - - RETURN - END - - subroutine read_netcdf_3d_para(ncid,im,jm,jsta,jsta_2l,jend,jend_2u, & - spval,varname,buf,lm) - - use netcdf - implicit none - INCLUDE "mpif.h" - - character(len=20),intent(in) :: varname - real,intent(in) :: spval - integer,intent(in) :: ncid,im,jm,lm,jsta_2l,jend_2u,jsta,jend - real,intent(out) :: buf(im,jsta_2l:jend_2u,lm) - integer :: varid,iret,jj,i,j,l,kk - integer :: start(3), count(3), stride(3) - - iret = nf90_inq_varid(ncid,trim(varname),varid) - if (iret /= 0) then - print*,VarName," not found -Assigned missing values" -!$omp parallel do private(i,j,l) - do l=1,lm - do j=jsta,jend - do i=1,im - buf(i,j,l)=spval - enddo - enddo - enddo - else - start = (/1,jsta,1/) - jj=jend-jsta+1 - count = (/im,jj,lm/) - iret = nf90_get_var(ncid,varid,buf(1:im,jsta:jend,1:lm),start=start,count=count) - endif - - end subroutine read_netcdf_3d_para - - subroutine read_netcdf_2d_para(ncid,im,jsta,jsta_2l,jend,jend_2u, & - spval,VarName,buf) - - use netcdf - implicit none - INCLUDE "mpif.h" - - character(len=20),intent(in) :: VarName - real,intent(in) :: spval - integer,intent(in) :: ncid,im,jsta_2l,jend_2u,jsta,jend - real,intent(out) :: buf(im,jsta_2l:jend_2u) - integer :: varid,iret,jj,i,j - integer :: start(2), count(2) - - iret = nf90_inq_varid(ncid,trim(varname),varid) - if (iret /= 0) then - print*,VarName," not found -Assigned missing values" -!$omp parallel do private(i,j) - do j=jsta,jend - do i=1,im - buf(i,j)=spval - enddo - enddo - else - start = (/1,jsta/) - jj=jend-jsta+1 - count = (/im,jj/) - iret = nf90_get_var(ncid,varid,buf(:,jsta),start=start,count=count) - endif - - end subroutine read_netcdf_2d_para diff --git a/sorc/ncep_post.fd/INITPOST_NEMS.f b/sorc/ncep_post.fd/INITPOST_NEMS.f index 39459701f..a88dfa3d6 100644 --- a/sorc/ncep_post.fd/INITPOST_NEMS.f +++ b/sorc/ncep_post.fd/INITPOST_NEMS.f @@ -1,39 +1,22 @@ !> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN NEMS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NEMS -!! INPUT ARGUMENT LIST: -!! NREC -!! NFILE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief initpost_nems() initializes post for run. +!> +!> @author Hui-Ya Chuang @date 2007-03-26 + +!> This routine initializes constants and +!> variables at the start of an NEMS model or post +!> processor run. +!> +!> @param[in] NREC. +!> @param[in] NFILE. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-03-01 | Hui-Ya Chuang | Initial +!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend) +!> +!> @author Hui-Ya Chuang @date 2007-03-26 SUBROUTINE INITPOST_NEMS(NREC,nfile) use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,& diff --git a/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f deleted file mode 100644 index 9aed1706b..000000000 --- a/sorc/ncep_post.fd/INITPOST_NEMS_MPIIO.f +++ /dev/null @@ -1,2464 +0,0 @@ -!> @file -! . . . -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2008-03-26 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN NEMS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NEMS -!! INPUT ARGUMENT LIST: -!! NREC -!! NFILE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_NEMS_MPIIO() - - use vrbls3d, only: t, q, uh, vh, q2, cwm, f_ice, f_rain, f_rimef, cfr, pint,& - pint, alpint, pmid, pmidv, zint, zmid, wh, rlwtt, rswtt,& - ttnd, tcucn, train, el_pbl, exch_h, omga - use vrbls2d, only: f, pd, fis, pblh, mixht, ustar, z0, ths, qs, twbs, qwbs, prec,& - acprec, cuprec,ancprc, lspa, sno, snoavg, psfcavg, t10avg, t10m, akhsavg, akmsavg,& - refd_max, w_up_max, w_dn_max, up_heli_max, si, cldefi, th10, q10, pshltr,& - tshltr, qshltr, maxtshltr, mintshltr, maxrhshltr, minrhshltr, akhs, akms, albase,& - albedo, czen, cfracl, cfracm, islope, cmc, grnflx, pctsno, soiltb, vegfrc,& - acfrcv, acfrst, ssroff, bgroff, czmean, mxsnal, radot, sigt4, tg, sr, cfrach,& - rlwin, rlwtoa, alwin, alwout, alwtoa, rswin, rswinc, rswout, aswin,aswout,& - aswtoa, sfcshx, sfclhx, subshx, snopcx, sfcuvx, potevp, ncfrcv, ncfrst, u10h,& - u10, v10h, v10, u10max, v10max, smstav, smstot, sfcevp, ivgtyp, acsnow, acsnom,& - sst, thz0, qz0, uz0, vz0, htop, isltyp, sfcexc, hbot, htopd, htops, cuppt, cprate,& - hbotd, hbots - use soil, only: sldpth, sh2o, smc, stc - use masks, only: lmv, lmh, htm, vtm, dx, dy, hbm2, gdlat, gdlon, sm, sice - use kinds, only: i_llong - use wrf_io_flags_mod, only: - use params_mod, only: pi, dtr, g, d608, rd - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, the0,& - ttblq, rdpq, rdtheq, stheq, the0q - use ctlblk_mod, only: me, mpi_comm_comp, global, icnt, idsp, jsta, ihrst, imin, idat, sdat,& - ifhr, ifmin, filename, restrt, imp_physics, isf_surface_physics, icu_physics, jend,& - dt, spval, gdsdegr, grib, pdtop, pt, tmaxmin, nsoil, lp1, jend_m, nprec, nphs, avrain,& - avcnvc, ardlw, ardsw, asrfc, novegtype, spl, lsm, dtq2, tsrfc, trdlw, trdsw, theat, tclod,& - tprec, alsl, lm , im, jm, jsta_2l, jend_2u, ivegsrc, pthresh - use gridspec_mod, only: dyval, dxval, cenlat, cenlon, maptype, gridtype, latstart, latlast, latnw,& - latse, lonstart, lonlast, lonnw, lonse, latstartv, latlastv, cenlatv, lonstartv,& - lonlastv, cenlonv -! use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_close, nemsio_getheadvar - use nemsio_module_mpi - use upp_math, only: h2u -! -! INCLUDE/SET PARAMETERS. - implicit none -! - type(nemsio_gfile) :: nfile -! - INCLUDE "mpif.h" -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - - character(len=8) :: VarName - character(len=8) :: VcoordName - integer :: Status - integer fldsize,fldst,recn - character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - LOGICAL RUNB,SINGLRST,SUBPOST,NEST,HYDRO - LOGICAL IOOMG,IOALL - logical, parameter :: debugprint = .false. - logical fliplayer ! whether or not to flip layer - logical :: convert_rad_to_deg=.false. -! logical global - CHARACTER*32 LABEL - CHARACTER*40 CONTRL,FILALL,FILMST,FILTMP,FILTKE,FILUNV & - , FILCLD,FILRAD,FILSFC - CHARACTER*4 RESTHR - CHARACTER FNAME*80,ENVAR*50,BLANK*4 - integer nfhour ! forecast hour from nems io file - INTEGER IDATE(8),JDATE(8) -! -! DECLARE VARIABLES. -! - REAL FACT,tsph,tstart - REAL RINC(5) - REAL ETA1(LM+1), ETA2(LM+1) - REAL GARB - REAL DUM1D (LM+1) - REAL DUMMY ( IM, JM ) -! REAL DUMMY2 ( IM, JM ) - real, allocatable :: fi(:,:,:) - integer ibuf(im,jsta_2l:jend_2u) - real buf(im,jsta_2l:jend_2u) - character*8,allocatable:: recname(:) - character*8,allocatable :: reclevtyp(:) - integer,allocatable:: reclev(:) - real, allocatable:: bufy(:) - real, allocatable:: glat1d(:),glon1d(:) - real, allocatable:: tmp(:) -!jw - integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, & - nsrfc,nrdlw,nrdsw,nheat,nclod, & - iunit,nrec,I,J,L, iret,nframe,impf,jmpf,nframed2, & - igdout,ll,n,im1,jm1,iim1 -! - DATA BLANK/' '/ -! -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST' -! -! -! STEP 1. READ MODEL OUTPUT FILE -! -!*** -! LMH always = LM for sigma-type vert coord -! LMV always = LM for sigma-type vert coord - - do j = jsta_2l, jend_2u - do i = 1, im - LMV ( i, j ) = lm - LMH ( i, j ) = lm - end do - end do - -! HTM VTM all 1 for sigma-type vert coord - - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM ( i, j, l ) = 1.0 - VTM ( i, j, l ) = 1.0 - end do - end do - end do - -! The end j row is going to be jend_2u for all variables except for V. - JS=JSTA_2L - JE=JEND_2U - IF (JEND_2U==JM) THEN - JEV=JEND_2U+1 - ELSE - JEV=JEND_2U - ENDIF -! sample print point - ii=(1+im)/2 - jj=(1+jm)/2 -! initialize nemsio using mpi io module - call nemsio_init() - call nemsio_open(nfile,trim(filename),'read',mpi_comm_comp,iret=status) - if ( Status /= 0 ) then - print*,'error opening ',fileName, ' Status = ', Status ; stop - endif - call nemsio_getfilehead(nfile,iret=status,nrec=nrec) - print*,'nrec=',nrec - allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) - call nemsio_getfilehead(nfile,iret=iret & - ,recname=recname ,reclevtyp=reclevtyp,reclev=reclev) - if (me == 0)then - do i=1,nrec - print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', & - trim(reclevtyp(i)),reclev(i) - end do - end if - -! get start date - idate=0 -! if (me == 0)then - call nemsio_getfilehead(nfile,iret=iret & - ,idate=idate(1:7),nfhour=nfhour,nframe=nframe) - - impf=im+nframe*2 - jmpf=jm+nframe*2 - print*,'nframe,impf,jmpf= ',nframe,impf,jmpf - allocate(glat1d(impf*jmpf),glon1d(impf*jmpf) ) - call nemsio_getfilehead(nfile,dx=glat1d & - ,dy=glon1d,iret=iret) - if(iret/=0)print*,'did not find dx dy' - do j=jsta,jend - do i=1,im - ! dummy(i,j) = glat1d((j-1)*impf+i+nframe) - ! dummy2(i,j) = glon1d((j-1)*impf+i+nframe) - dx(i,j)= glat1d((j-1)*impf+i+nframe) - dy(i,j)= glon1d((j-1)*impf+i+nframe) - end do - end do - deallocate(glat1d,glon1d) - print*,'idate before broadcast = ',(idate(i),i=1,7) -! end if !for me=0 -! call mpi_bcast(idate(1),7,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(nfhour,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(nframe,1,MPI_INTEGER,0,mpi_comm_comp,iret) - - IF(.not. global)THEN - impf=im+nframe*2 - jmpf=jm+nframe*2 - ELSE - impf=im+1 ! post cut im off because it's the same as i=1 but data from model is till im - jmpf=jm - END IF - print*,'impf,jmpf,nframe for reading fields = ',impf,jmpf,nframe - print*,'idate after broadcast = ',(idate(i),i=1,7) - print*,'nfhour = ',nfhour - !call mpi_scatterv(dummy(1,1),icnt,idsp,mpi_real & - ! ,dx(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - !call mpi_scatterv(dummy2(1,1),icnt,idsp,mpi_real & - ! ,dy(1,jsta),icnt(me),mpi_real,0,MPI_COMM_COMP,iret) - - - iyear = idate(1) - imn = idate(2) ! ask Jun - iday = idate(3) ! ask Jun - ihrst = idate(4) - imin = idate(5) - jdate = 0 - idate = 0 -! -! read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=' & - ,idat(3),idat(1),idat(2),idat(4),idat(5) -! - idate(1) = iyear - idate(2) = imn - idate(3) = iday - idate(5) = ihrst - idate(6) = imin - SDAT(1) = imn - SDAT(2) = iday - SDAT(3) = iyear - jdate(1) = idat(3) - jdate(2) = idat(1) - jdate(3) = idat(2) - jdate(5) = idat(4) - jdate(6) = idat(5) -! - print *,' idate=',idate - print *,' jdate=',jdate -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) -! - CALL W3DIFDAT(JDATE,IDATE,0,RINC) -! - print *,' rinc=',rinc - ifhr=nint(rinc(2)+rinc(1)*24.) - print *,' ifhr=',ifhr - ifmin=nint(rinc(3)) -! if(ifhr /= nfhour)print*,'find wrong Model input file';stop - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! Getting tstart - tstart=0. - print*,'tstart= ',tstart - -! Getiing restart - - RESTRT=.TRUE. ! set RESTRT as default -! call ext_int_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp -! + ,1,ioutcount,istatus) - -! IF(itmp < 1)THEN -! RESTRT=.FALSE. -! ELSE -! RESTRT=.TRUE. -! END IF - -! print*,'status for getting RESTARTBIN= ',istatus - -! print*,'Is this a restrt run? ',RESTRT - - IF(tstart > 1.0E-2)THEN - ifhr=ifhr+NINT(tstart) - rinc=0 - idate=0 - rinc(2)=-1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1)=idate(2) - SDAT(2)=idate(3) - SDAT(3)=idate(1) - IHRST=idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1) & - ,sdat(2),ihrst,imin - END IF - - VarName='mp_physi' - !if(me == 0)then - call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) - if (iret /= 0) then - print*,VarName," not found in file- go to 16 character " - VarName='mp_physics' - call nemsio_getheadvar(nfile,trim(VarName),imp_physics,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 1000" - imp_physics=1000 - end if - end if - !end if - !call mpi_bcast(imp_physics,1,MPI_INTEGER,0,mpi_comm_comp,iret) - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - - VarName='sf_surface_physi' - call nemsio_getheadvar(nfile,trim(VarName),iSF_SURFACE_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 2 for NOAH LSM as default" - iSF_SURFACE_PHYSICS=2 - end if - print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS - -! IVEGSRC=1 for IGBP and 0 for USGS - VarName='IVEGSRC' - call nemsio_getheadvar(nfile,trim(VarName),IVEGSRC,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 1 for IGBP as default" - IVEGSRC=1 - end if - print*,'IVEGSRC= ',IVEGSRC - -! set novegtype based on vegetation classification - if(ivegsrc==1)then - novegtype=20 - else if(ivegsrc==0)then - novegtype=24 - end if - print*,'novegtype= ',novegtype - - VarName='CU_PHYSICS' - call nemsio_getheadvar(nfile,trim(VarName),iCU_PHYSICS,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned 2 for BMJ as default" - iCU_PHYSICS=2 - end if - print*,'CU_PHYSICS= ',iCU_PHYSICS - - - allocate(bufy(jm)) - VarName='DX' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dx=spval -! end if -! end if -! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) -! do j=jsta,jend -! do i=1,im -! dx(i,j)=bufy(j) -! end do -! end do - if(debugprint)print*,'sample ',VarName,' = ',dx(im/2,(jsta+jend)/2) - - VarName='DY' -! if(me == 0)then -! call nemsio_getheadvar(nfile,trim(VarName),bufy,iret) -! if (iret /= 0) then -! print*,VarName," not found in file-Assigned missing values" -! dx=spval -! end if -! end if -! call mpi_bcast(bufy,jm,MPI_REAL,0,mpi_comm_comp,iret) -! do j=jsta,jend -! do i=1,im -! dy(i,j)=bufy(j) -! end do -! end do - if(debugprint)print*,'sample ',VarName,' = ',dy(im/2,(jsta+jend)/2) - deallocate(bufy) - - VarName='dt' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dt=spval - else - dt=garb - end if - - VarName='dphd' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dyval=spval - else - dyval=garb*gdsdegr - end if -! dyval=106 ! hard wire for AQ domain testing - - VarName='dlmd' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - dxval=spval - else - dxval=garb*gdsdegr - end if -! dxval=124 ! hard wire for AQ domain testing - - print*,'DX, DY, DT=',dxval,dyval,dt - - VarName='TPH0D' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - cenlat=spval - else - cenlat=nint(garb*gdsdegr) - end if - - VarName='TLM0D' - call nemsio_getheadvar(nfile,trim(VarName),garb,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - cenlon=spval - else - if(grib=="grib2") then - cenlon=nint((garb+360.)*gdsdegr) - endif - end if - - varname='sg1' - call nemsio_getheadvar(nfile,trim(varname),eta1,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - ETA1=SPVAL - end if - - varname='sg2' - call nemsio_getheadvar(nfile,trim(varname),eta2,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - ETA2=SPVAL - end if - if(me==0)then - open(75,file='ETAPROFILE.txt',form='formatted', & - status='unknown') - DO L=1,lm+1 - write(75,1020)L, ETA1(lm+2-l), ETA2(lm+2-l) - END DO - 1020 format(I3,2E17.10) - close (75) - end if - - varname='pdtop' - call nemsio_getheadvar(nfile,trim(varname),pdtop,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - pdtop=SPVAL - end if - - varname='pt' - call nemsio_getheadvar(nfile,trim(varname),pt,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned missing values" - pt=SPVAL - end if - print*,'PT, PDTOP= ',PT,PDTOP - - VarName='sldpth' - call nemsio_getheadvar(nfile,trim(varname),sldpth,iret) - print*,'SLDPTH= ',(SLDPTH(N),N=1,NSOIL) - -! set default to not empty buket - nprec=0 - nphs=0 - nclod=0 - nheat=0 - nrdlw=0 - nrdsw=0 - nsrfc=0 - - VarName='nprec' - call nemsio_getheadvar(nfile,trim(varname),nprec,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nprec - - VarName='nphs' - call nemsio_getheadvar(nfile,trim(varname),nphs,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nphs - - VarName='nclod' - call nemsio_getheadvar(nfile,trim(varname),nclod,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nclod - - VarName='nheat' - call nemsio_getheadvar(nfile,trim(varname),nheat,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nheat - - VarName='nrdlw' - call nemsio_getheadvar(nfile,trim(varname),nrdlw,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nrdlw - - VarName='nrdsw' - call nemsio_getheadvar(nfile,trim(varname),nrdsw,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nrdsw - - VarName='nsrfc' - call nemsio_getheadvar(nfile,trim(varname),nsrfc,iret) - if (iret /= 0) then - print*,VarName," not found in file-Assigned zero" - end if - if(debugprint)print*,'sample ',VarName,' = ',nsrfc - - IF(.not. global)THEN - maptype=205 ! for Arakawa-B grid - gridtype='B' - ELSE - maptype=0 ! for global NMMB on latlon grid - gridtype='A' ! will put wind on mass point for now to make regular latlon - END IF - print*,'maptype and gridtype= ',maptype,gridtype - - HBM2=1.0 - -! start reading nemsio files using parallel read - fldsize=(jend-jsta+1)*im - allocate(tmp(fldsize*nrec)) - print*,'allocate tmp successfully' - tmp=0. - call nemsio_denseread(nfile,1,im,jsta,jend,tmp,iret=iret) - if(iret/=0)then - print*,"fail to read nemsio file using mpi io read, stopping" - stop - end if - - varname='glat' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,gdlat) - - call collect_loc(gdlat,dummy) -! decides whether or not to convert to degree - if(me==0)then - if(maxval(abs(dummy))0. .and. gdlon(2,jsta)<0.)then - do j=jsta,jend - gdlon(1,j)=gdlon(1,j)-360.0 - end do - end if - end if - if(debugprint)print*,'sample ',VarName,' = ',(gdlon(i,(jsta+jend)/2),i=1,im,8) - if(debugprint)print*,'max min lon=',maxval(gdlon),minval(gdlon) - call collect_loc(gdlon,dummy) - if(me==0)then - if(grib=='grib2') then - if(dummy(1,1)<0) dummy(1,1)=dummy(1,1)+360. - if(dummy(im,jm)<0) dummy(im,jm)=dummy(im,jm)+360. - endif - lonstart=nint(dummy(1,1)*gdsdegr) - lonlast=nint(dummy(im,jm)*gdsdegr) - lonnw=nint(dummy(1,jm)*gdsdegr) - lonse=nint(dummy(im,1)*gdsdegr) -! dxval=nint((dummy(2,1)-dummy(1,1))*1000.) -! dxval=124 ! hard wire for AQ domain testing - if(mod(im,2)==0)then -! cenlon=nint((dummy(ii,jj)+dummy(ii+1,jj)+dummy(ii+1,jj+1)+dummy(ii,jj+1))/4.0*1000.) - else -! cenlon=nint(dummy(ii,jj)*1000.) - end if - end if - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,iret) - call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(dxval,1,MPI_INTEGER,0,mpi_comm_comp,iret) -! call mpi_bcast(cenlon,1,MPI_INTEGER,0,mpi_comm_comp,iret) - write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast - print*,'dxval, cenlon= ',dxval, cenlon - - convert_rad_to_deg=.false. - varname='vlat' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,buf) - - if(debugprint)print*,'sample ',VarName,' = ',buf(im/2,(jsta+jend)/2) - if(debugprint)print*,'max min vlat=',maxval(buf),minval(buf) - call collect_loc(buf,dummy) - if(me==0)then - if(maxval(abs(dummy)) 27.0 .or. sfcevp(i,j)<1.0)print*, & -! 'bad vegtype=',i,j,sfcevp(i,j) -! end do -! end do - - where(sfcevp /= spval)IVGTYP=nint(sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',IVGTYP(im/2,(jsta+jend)/2) - - sfcevp=spval - VarName='sltyp' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sfcevp) ! temporary use sfcevp because it's real in nemsio - where(sfcevp /= spval)ISLTYP=nint(sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',ISLTYP(im/2,(jsta+jend)/2) - - sfcevp=spval - VarName='sfcevp' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sfcevp) - if(debugprint)print*,'sample ',VarName,' = ',sfcevp(im/2,(jsta+jend)/2) - - VarName='sfcexc' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sfcexc) - if(debugprint)print*,'sample ',VarName,' = ',sfcexc(im/2,(jsta+jend)/2) - if(debugprint)print*,'MAX/MIN ',VarName,' = ' & - ,maxval(sfcexc),minval(sfcexc) - - VarName='acsnow' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,acsnow) - if(debugprint)print*,'sample ',VarName,' = ',acsnow(im/2,(jsta+jend)/2) - - VarName='acsnom' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,acsnom) - if(debugprint)print*,'sample ',VarName,' = ',acsnom(im/2,(jsta+jend)/2) - - VarName='tsea' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,sst) - if(debugprint)print*,'sample ',VarName,' = ',sst(im/2,(jsta+jend)/2) - -! VarName='EL_PBL' ! not in nems io yet - VarName='xlen_mix' - VcoordName='mid layer' - do l=1,lm -! ll=lm-l+1 - ll=l - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,ll,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,EL_PBL(1,jsta_2l,ll)) - if(debugprint)print*,'sample l ',VarName,' = ',ll,EL_PBL(im/2,(jsta+jend)/2,ll) - end do ! do loop for l - - VarName='exch_h' - VcoordName='mid layer' - do l=1,lm -! ll=lm-l+1 - ll=l - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,ll,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,exch_h(1,jsta_2l,ll)) - if(debugprint)print*,'sample l ',VarName,' = ',ll,exch_h(im/2,(jsta+jend)/2,ll) - end do ! do loop for l - - VarName='thz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,thz0) - if(debugprint)print*,'sample ',VarName,' = ',thz0(im/2,(jsta+jend)/2) - - VarName='qz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,qz0) - if(debugprint)print*,'sample ',VarName,' = ',qz0(im/2,(jsta+jend)/2) - - VarName='uz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,uz0) - if(debugprint)print*,'sample ',VarName,' = ',uz0(im/2,(jsta+jend)/2) - - VarName='vz0' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,vz0) - if(debugprint)print*,'sample ',VarName,' = ',vz0(im/2,(jsta+jend)/2) - -! -! Very confusing story ... -! -! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and -! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent -! the 3 sets of convective cloud base/top arrays tied to the frequency -! that history files are written. -! -! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are -! used in radiation and are tied to the frequency of radiation updates. -! -! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP -! and manipulated throughout the post. - -! retrieve htop and hbot -! VarName='HTOP' - VarName='cnvtop' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,htop) - where(htop /= spval)htop=float(lm)-htop+1.0 -! where(htop /= spval .and. htop > lm)htop=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htop(im/2,(jsta+jend)/2) - -! VarName='HBOT' - VarName='cnvbot' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,hbot) - where(hbot /= spval)hbot=float(lm)-hbot+1.0 -! where(hbot /= spval .and. hbot > lm)hbot=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbot(im/2,(jsta+jend)/2) - - VarName='htopd' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,htopd) - where(htopd /= spval)htopd=float(lm)-htopd+1.0 -! where(htopd /= spval .and. htopd > lm)htopd=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htopd(im/2,(jsta+jend)/2) - - VarName='hbotd' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,hbotd) - where(hbotd /= spval)hbotd=float(lm)-hbotd+1.0 -! where(hbotd /= spval .and. hbotd > lm)hbotd=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbotd(im/2,(jsta+jend)/2) - - VarName='htops' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,htops) - where(htops /= spval)htops=float(lm)-htops+1.0 -! where(htops /= spval .and. htops > lm)htops=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',htops(im/2,(jsta+jend)/2) - - VarName='hbots' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,hbots) - where(hbots /= spval)hbots=float(lm)-hbots+1.0 -! where(hbots /= spval .and. hbots > lm)hbots=lm*1.0 - if(debugprint)print*,'sample ',VarName,' = ',hbots(im/2,(jsta+jend)/2) - - VarName='cuppt' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,cuppt) - if(debugprint)print*,'sample ',VarName,' = ',cuppt(im/2,(jsta+jend)/2) - - VarName='cprate' - VcoordName='sfc' - l=1 - call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u & - ,l,nrec,fldsize,spval,tmp & - ,recname,reclevtyp,reclev,VarName,VcoordName & - ,cprate) - if(debugprint)print*,'sample ',VarName,' = ',cprate(im/2,(jsta+jend)/2) - - deallocate(tmp,recname,reclevtyp,reclev) -!!!! DONE GETTING - - do l = 1, lm - do j = jsta, jend - do i = 1, im - IF(ABS(T(I,J,L))>1.0E-3) & - OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G/ & - (RD*T(I,J,L)*(1.+D608*Q(I,J,L))) - - end do - end do - end do - write(0,*)' after OMGA' - - - THL=210. - PLQ=70000. - - CALL TABLE(PTBL,TTBL,PT, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - write(0,*)' after TABLEQ' - - -! -! - IF(ME==0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! -!MEB need to get DT -! DT = 120. !MEB need to get DT -! NPHS = 4 !MEB need to get physics DT - DTQ2 = DT * NPHS !MEB need to get physics DT - TSPH = 3600./DT !MEB need to get DT - - IF (PTHRESH>0.) THEN - PTHRESH=0.01*DTQ2/3.6E6 !-- Precip rate >= 0.01 mm/h -! PTHRESH=0.01*DTQ2/(3600.*39.37) !-- Precip rate >= 0.01 inches/h - ENDIF - - TSRFC=float(NSRFC)/TSPH - IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied - TRDLW=float(NRDLW)/TSPH - IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied - TRDSW=float(NRDSW)/TSPH - IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied - THEAT=float(NHEAT)/TSPH - IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied - TCLOD=float(NCLOD)/TSPH - IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied - TPREC=float(NPREC)/TSPH - IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied -! TPREC=float(ifhr) - print*,'TSRFC TRDLW TRDSW THEAT TCLOD TPREC= ' & - ,TSRFC, TRDLW, TRDSW, THEAT, TCLOD, TPREC -!MEB need to get DT - -!how am i going to get this information? -! NPREC = INT(TPREC *TSPH+D50) -! NHEAT = INT(THEAT *TSPH+D50) -! NCLOD = INT(TCLOD *TSPH+D50) -! NRDSW = INT(TRDSW *TSPH+D50) -! NRDLW = INT(TRDLW *TSPH+D50) -! NSRFC = INT(TSRFC *TSPH+D50) -!how am i going to get this information? -! -! IF(ME==0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. - DO L = 1,LSM - ALSL(L) = ALOG(SPL(L)) - END DO - write(0,*)' after ALSL' -! -!HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - if(me==0)then - print*,'writing out igds' - igdout=110 -! open(igdout,file='griddef.out',form='unformatted' -! + ,status='unknown') - IF(MAPTYPE==203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)LATLAST - WRITE(igdout)LONLAST - ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID - WRITE(igdout)205 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)LATLAST - WRITE(igdout)LONLAST - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - END IF - open(111,file='copygb_gridnav.txt',form='formatted' & - ,status='unknown') - IF(MAPTYPE==203)THEN !A STAGGERED E-GRID - write(111,1000) 2*IM-1,JM,LATSTART,LONSTART,CENLON, & - NINT(dxval*107.),NINT(dyval*110.),CENLAT,CENLAT - ELSE IF(MAPTYPE==205)THEN !A STAGGERED B-GRID - if(grib=="grib2") then - write(111,1000) IM,JM,LATSTART/1000,LONSTART/1000,CENLON/1000, & - NINT(dxval*107.)/1000,NINT(dyval*110.)/1000, & - CENLAT/1000,CENLAT/1000, & - LATLAST/1000,LONLAST/1000 - endif - END IF -1000 format('255 3 ',2(I4,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', & - 3(x,I6),x,I7) - close(111) -! - IF (MAPTYPE==205)THEN !A STAGGERED B-GRID - open(112,file='latlons_corners.txt',form='formatted' & - ,status='unknown') - if(grib=="grib2") then - write(112,1001)LATSTART/1000,(LONSTART/1000)-360000, & - LATSE/1000, & - LONSE/1000,LATNW/1000,LONNW/1000,LATLAST/1000, & - (LONLAST/1000)-360000 - endif -1001 format(4(I6,x,I7,x)) - close(112) - ENDIF - - end if - -! close all files - call nemsio_close(nfile,iret=status) - call nemsio_finalize() -! - write(0,*)'end of INIT_NEMS' - - RETURN - END diff --git a/sorc/ncep_post.fd/INITPOST_NETCDF.f b/sorc/ncep_post.fd/INITPOST_NETCDF.f index 4476acf5b..17d79845b 100644 --- a/sorc/ncep_post.fd/INITPOST_NETCDF.f +++ b/sorc/ncep_post.fd/INITPOST_NETCDF.f @@ -1,39 +1,27 @@ !> @file -! . . . -!> SUBPROGRAM: INITPOST_NETCDF INITIALIZE POST FOR RUN -!! PRGRMMR: Hui-Ya Chuang DATE: 2016-03-04 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF GFS MODEL OR POST -!! PROCESSOR RUN. -!! -!! REVISION HISTORY -!! 2017-08-11 H Chuang start from INITPOST_GFS_NEMS_MPIIO.f -!! 2021-03-11 Bo Cui change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INITPOST_NETCDF -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief initpost_netcdf() initializes post for run. +!> +!> @author Hui-Ya Chuang @date 2016-03-04 + +!> This routine initializes constants and +!> variables at the start of GFS model or post +!> processor run. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-03-01 | Hui-Ya Chuang | Initial. Start from INITPOST_GFS_NEMS_MPIIO.f +!> 2021-03-11 | Bo Cui | Change local arrays to dimension (im,jsta:jend) +!> 2021-10-26 | Jesse Meng | 2D DECOMPOSITION +!> 2022-02-07 | Wen Meng | Changes for parallel netcdf read +!> 2022-03-15 | Wen Meng | Unify regional and global interfaces +!> 2022-03-22 | Wen Meng | Read PWAT from model +!> 2022-04-08 | Bo Cui | 2D decomposition for unified fv3 read interfaces +!> 2022-06-05 | Hui-Ya Chuang | Modify dx/dy computation for RRFS domain over north pole +!> 2022-07-10 | Wen Meng | Output lat/lon on four coner points of rotated lat-lon grids in text file. +!> 2022-07-18 | Wen Meng | Read instant top of atmos ULWRF from model +!> +!> @author Hui-Ya Chuang @date 2016-03-04 SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) @@ -49,7 +37,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, & cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, & - tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, & + tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, landfrac, radot, sigt4, & cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, & islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, & bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, & @@ -57,15 +45,17 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) snopcx, sfcux, sfcvx, sfcuxi, sfcvxi, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, & smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, & uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, & - ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, & + ptoph, pboth, pblcfr, ttoph, runoff, tecan, tetran, tedir, twa, maxtshltr, & + mintshltr, maxrhshltr, fdnsst, & minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, & cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa,rel_vort_maxhy1, & maxqshltr, minqshltr, acond, sr, u10h, v10h,refd_max, w_up_max, w_dn_max, & up_heli_max,up_heli_min,up_heli_max03,up_heli_min03,rel_vort_max01,u10max, v10max, & - avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & + avgedir,avgecan,paha,pahi,avgetrans,avgesnow,avgprec_cont,avgcprate_cont,rel_vort_max, & avisbeamswin,avisdiffswin,airbeamswin,airdiffswin,refdm10c_max,wspd10max, & alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, & - ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550,prate_max + ti,aod550,du_aod550,ss_aod550,su_aod550,oc_aod550,bc_aod550,prate_max, & + pwat use soil, only: sldpth, sllevel, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, & @@ -79,10 +69,12 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, & jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, & nbin_oc, nbin_su, gocart_on, pt_tbl, hyb_sigp, filenameFlux, fileNameAER, & - iSF_SURFACE_PHYSICS,rdaod, aqfcmaq_on, modelname, smflag + iSF_SURFACE_PHYSICS,rdaod, aqfcmaq_on, modelname, smflag, & + ista, iend, ista_2l, iend_2u,iend_m use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, & dxval, dyval, truelat2, truelat1, psmapf, cenlat,lonstartv, lonlastv, cenlonv, & - latstartv, latlastv, cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r, STANDLON + latstartv, latlastv,cenlatv,latstart_r,latlast_r,lonstart_r,lonlast_r, STANDLON, & + latse,lonse,latnw,lonnw use upp_physics, only: fpvsnew !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -115,7 +107,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) character(len=20) :: VarName, VcoordName integer :: Status, fldsize, fldst, recn, recn_vvel character startdate*19,SysDepInfo*80,cgar*1 - character startdate2(19)*4 + character startdate2(19)*4, flatlon*40 logical :: read_lonlat=.true. ! ! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK @@ -159,15 +151,14 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) real, allocatable :: wrk1(:,:), wrk2(:,:) real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), & qs2d(:,:), cw2d(:,:), cfr2d(:,:) - real(kind=4),allocatable :: vcoord4(:,:,:) real, dimension(lm+1) :: ak5, bk5 real*8, allocatable :: pm2d(:,:), pi2d(:,:) real, allocatable :: tmp(:) - real :: buf(im,jsta_2l:jend_2u) - real :: buf3d(im,jsta_2l:jend_2u,lm) + real :: buf(ista_2l:iend_2u,jsta_2l:jend_2u) + real :: buf3d(ista_2l:iend_2u,jsta_2l:jend_2u,lm) -! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & -! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) +! real buf(ista_2l:iend_2u,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) & +! ,buf3d(ista_2l:iend_2u,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u) real LAT integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass @@ -234,137 +225,137 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) if (aqfcmaq_on) then - allocate(aacd(im,jsta_2l:jend_2u,lm)) - allocate(aalj(im,jsta_2l:jend_2u,lm)) - allocate(aalk1j(im,jsta_2l:jend_2u,lm)) - allocate(aalk2j(im,jsta_2l:jend_2u,lm)) + allocate(aacd(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aalj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aalk1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aalk2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(abnz1j(im,jsta_2l:jend_2u,lm)) - allocate(abnz2j(im,jsta_2l:jend_2u,lm)) - allocate(abnz3j(im,jsta_2l:jend_2u,lm)) + allocate(abnz1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(abnz2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(abnz3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(acaj(im,jsta_2l:jend_2u,lm)) - allocate(acet(im,jsta_2l:jend_2u,lm)) + allocate(acaj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(acet(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(acli(im,jsta_2l:jend_2u,lm)) - allocate(aclj(im,jsta_2l:jend_2u,lm)) - allocate(aclk(im,jsta_2l:jend_2u,lm)) + allocate(acli(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aclj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aclk(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(acors(im,jsta_2l:jend_2u,lm)) - allocate(acro_primary(im,jsta_2l:jend_2u,lm)) - allocate(acrolein(im,jsta_2l:jend_2u,lm)) - allocate(aeci(im,jsta_2l:jend_2u,lm)) - allocate(aecj(im,jsta_2l:jend_2u,lm)) - allocate(afej(im,jsta_2l:jend_2u,lm)) - allocate(aglyj(im,jsta_2l:jend_2u,lm)) + allocate(acors(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(acro_primary(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(acrolein(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aeci(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aecj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(afej(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aglyj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(ah2oi(im,jsta_2l:jend_2u,lm)) - allocate(ah2oj(im,jsta_2l:jend_2u,lm)) - allocate(ah2ok(im,jsta_2l:jend_2u,lm)) + allocate(ah2oi(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ah2oj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ah2ok(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(ah3opi(im,jsta_2l:jend_2u,lm)) - allocate(ah3opj(im,jsta_2l:jend_2u,lm)) - allocate(ah3opk(im,jsta_2l:jend_2u,lm)) + allocate(ah3opi(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ah3opj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ah3opk(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aiso1j(im,jsta_2l:jend_2u,lm)) - allocate(aiso2j(im,jsta_2l:jend_2u,lm)) - allocate(aiso3j(im,jsta_2l:jend_2u,lm)) + allocate(aiso1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aiso2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aiso3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aivpo1j(im,jsta_2l:jend_2u,lm)) - allocate(akj(im,jsta_2l:jend_2u,lm)) + allocate(aivpo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(akj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(ald2(im,jsta_2l:jend_2u,lm)) - allocate(ald2_primary(im,jsta_2l:jend_2u,lm)) + allocate(ald2(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ald2_primary(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aldx(im,jsta_2l:jend_2u,lm)) + allocate(aldx(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(alvoo1i(im,jsta_2l:jend_2u,lm)) - allocate(alvoo1j(im,jsta_2l:jend_2u,lm)) - allocate(alvoo2i(im,jsta_2l:jend_2u,lm)) - allocate(alvoo2j(im,jsta_2l:jend_2u,lm)) - allocate(alvpo1i(im,jsta_2l:jend_2u,lm)) - allocate(alvpo1j(im,jsta_2l:jend_2u,lm)) + allocate(alvoo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(alvoo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(alvoo2i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(alvoo2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(alvpo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(alvpo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(amgj(im,jsta_2l:jend_2u,lm)) - allocate(amnj(im,jsta_2l:jend_2u,lm)) + allocate(amgj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(amnj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(anai(im,jsta_2l:jend_2u,lm)) - allocate(anaj(im,jsta_2l:jend_2u,lm)) - allocate(anak(im,jsta_2l:jend_2u,lm)) + allocate(anai(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(anaj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(anak(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(anh4i(im,jsta_2l:jend_2u,lm)) - allocate(anh4j(im,jsta_2l:jend_2u,lm)) - allocate(anh4k(im,jsta_2l:jend_2u,lm)) + allocate(anh4i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(anh4j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(anh4k(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(ano3i(im,jsta_2l:jend_2u,lm)) - allocate(ano3j(im,jsta_2l:jend_2u,lm)) - allocate(ano3k(im,jsta_2l:jend_2u,lm)) + allocate(ano3i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ano3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(ano3k(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aolgaj(im,jsta_2l:jend_2u,lm)) - allocate(aolgbj(im,jsta_2l:jend_2u,lm)) + allocate(aolgaj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aolgbj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aomi(im,jsta_2l:jend_2u,lm)) - allocate(aomj(im,jsta_2l:jend_2u,lm)) + allocate(aomi(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aomj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aorgcj(im,jsta_2l:jend_2u,lm)) + allocate(aorgcj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aothri(im,jsta_2l:jend_2u,lm)) - allocate(aothrj(im,jsta_2l:jend_2u,lm)) + allocate(aothri(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aothrj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(apah1j(im,jsta_2l:jend_2u,lm)) - allocate(apah2j(im,jsta_2l:jend_2u,lm)) - allocate(apah3j(im,jsta_2l:jend_2u,lm)) + allocate(apah1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(apah2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(apah3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(apcsoj(im,jsta_2l:jend_2u,lm)) + allocate(apcsoj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(apomi(im,jsta_2l:jend_2u,lm)) - allocate(apomj(im,jsta_2l:jend_2u,lm)) + allocate(apomi(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(apomj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aseacat(im,jsta_2l:jend_2u,lm)) - allocate(asij(im,jsta_2l:jend_2u,lm)) + allocate(aseacat(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asij(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(aso4i(im,jsta_2l:jend_2u,lm)) - allocate(aso4j(im,jsta_2l:jend_2u,lm)) - allocate(aso4k(im,jsta_2l:jend_2u,lm)) - allocate(asoil(im,jsta_2l:jend_2u,lm)) + allocate(aso4i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aso4j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(aso4k(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asoil(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(asomi(im,jsta_2l:jend_2u,lm)) - allocate(asomj(im,jsta_2l:jend_2u,lm)) + allocate(asomi(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asomj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(asqtj(im,jsta_2l:jend_2u,lm)) + allocate(asqtj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(asvoo1i(im,jsta_2l:jend_2u,lm)) - allocate(asvoo1j(im,jsta_2l:jend_2u,lm)) - allocate(asvoo2i(im,jsta_2l:jend_2u,lm)) - allocate(asvoo2j(im,jsta_2l:jend_2u,lm)) - allocate(asvoo3j(im,jsta_2l:jend_2u,lm)) + allocate(asvoo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvoo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvoo2i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvoo2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvoo3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(asvpo1i(im,jsta_2l:jend_2u,lm)) - allocate(asvpo1j(im,jsta_2l:jend_2u,lm)) - allocate(asvpo2i(im,jsta_2l:jend_2u,lm)) - allocate(asvpo2j(im,jsta_2l:jend_2u,lm)) - allocate(asvpo3j(im,jsta_2l:jend_2u,lm)) + allocate(asvpo1i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvpo1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvpo2i(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvpo2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(asvpo3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(atij(im,jsta_2l:jend_2u,lm)) + allocate(atij(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(atol1j(im,jsta_2l:jend_2u,lm)) - allocate(atol2j(im,jsta_2l:jend_2u,lm)) - allocate(atol3j(im,jsta_2l:jend_2u,lm)) + allocate(atol1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(atol2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(atol3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(atoti(im,jsta_2l:jend_2u,lm)) - allocate(atotj(im,jsta_2l:jend_2u,lm)) - allocate(atotk(im,jsta_2l:jend_2u,lm)) + allocate(atoti(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(atotj(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(atotk(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(atrp1j(im,jsta_2l:jend_2u,lm)) - allocate(atrp2j(im,jsta_2l:jend_2u,lm)) + allocate(atrp1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(atrp2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(axyl1j(im,jsta_2l:jend_2u,lm)) - allocate(axyl2j(im,jsta_2l:jend_2u,lm)) - allocate(axyl3j(im,jsta_2l:jend_2u,lm)) + allocate(axyl1j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(axyl2j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(axyl3j(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) - allocate(pm25ac(im,jsta_2l:jend_2u,lm)) - allocate(pm25at(im,jsta_2l:jend_2u,lm)) - allocate(pm25co(im,jsta_2l:jend_2u,lm)) + allocate(pm25ac(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pm25at(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pm25co(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) endif @@ -374,14 +365,17 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) WRITE(6,*)'INITPOST: ENTER INITPOST_NETCDF' WRITE(6,*)'me=',me, & 'jsta_2l=',jsta_2l,'jend_2u=', & - jend_2u,'im=',im + jend_2u,'im=',im, & + 'ista_2l=',ista_2l,'iend_2u=',iend_2u, & + 'ista=',ista,'iend=',iend, & + 'iend_m=',iend_m ! - isa = im / 2 + isa = (ista+iend) / 2 jsa = (jsta+jend) / 2 !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i=1,im + do i= ista_2l, iend_2u buf(i,j) = spval enddo enddo @@ -477,8 +471,8 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) dyval=dum_const*gdsdegr end if - print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & - lonstart,latstart,cenlon,cenlat,dyval,dxval +! print*,'lonstart,latstart,cenlon,cenlat,dyval,dxval', & +! lonstart,latstart,cenlon,cenlat,dyval,dxval ! Jili Dong add support for regular lat lon (2019/03/22) start else if(trim(varcharval)=='latlon')then @@ -616,9 +610,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) end if STANDLON = cenlon - print*,'lonstart,latstart,cenlon,cenlat,truelat1,truelat2,stadlon,dyval,dxval', & + print*,'lonstart,latstart,cenlon,cenlat,truelat1,truelat2, & + stadlon,dyval,dxval', & lonstart,latstart,cenlon,cenlat,truelat1,truelat2,standlon,dyval,dxval + else if(trim(varcharval)=='gaussian')then + MAPTYPE=4 + idrt=4 else ! setting default maptype MAPTYPE=0 idrt=0 @@ -635,7 +633,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) !$omp parallel do private(i,j) do j = jsta_2l, jend_2u - do i = 1, im + do i = ista_2l, iend_2u LMV(i,j) = lm LMH(i,j) = lm end do @@ -646,7 +644,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) !$omp parallel do private(i,j,l) do l = 1, lm do j = jsta_2l, jend_2u - do i = 1, im + do i = ista_2l, iend_2u HTM (i,j,l) = 1.0 VTM (i,j,l) = 1.0 end do @@ -676,7 +674,6 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) ! write(0,*)'nrec=',nrec !allocate(recname(nrec),reclevtyp(nrec),reclev(nrec)) allocate(glat1d(jm),glon1d(im)) - allocate(vcoord4(lm+1,3,2)) ! hardwire idate for now ! idate=(/2017,08,07,00,0,0,0,0/) @@ -711,7 +708,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) ! Jili Dong check output format for coordinate reading Status=nf90_inq_varid(ncid3d,'grid_xt',varid) Status=nf90_inquire_variable(ncid3d,varid,ndims = numDims) - if(numDims==1) then + if(numDims==1.and.modelname=="FV3R") then read_lonlat=.true. else read_lonlat=.false. @@ -732,7 +729,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) if(numDims==1)then Status=nf90_get_var(ncid3d,varid,glon1d) do j=jsta,jend - do i=1,im + do i=ista,iend gdlon(i,j) = real(glon1d(i),kind=4) end do end do @@ -755,13 +752,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) if(maxval(abs(dummy))<2.0*pi)convert_rad_to_deg=.true. if(convert_rad_to_deg)then do j=jsta,jend - do i=1,im + do i=ista,iend gdlon(i,j) = real(dummy(i,j),kind=4)*180./pi end do end do else do j=jsta,jend - do i=1,im + do i=ista,iend gdlon(i,j) = real(dummy(i,j),kind=4) end do end do @@ -769,9 +766,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) if(convert_rad_to_deg)then lonstart = nint(dummy(1,1)*gdsdegr)*180./pi lonlast = nint(dummy(im,jm)*gdsdegr)*180./pi + lonse = nint(dummy(im,1)*gdsdegr)*180./pi + lonnw = nint(dummy(1,jm)*gdsdegr)*180./pi else lonstart = nint(dummy(1,1)*gdsdegr) lonlast = nint(dummy(im,jm)*gdsdegr) + lonse = nint(dummy(im,1)*gdsdegr) + lonnw = nint(dummy(1,jm)*gdsdegr) end if ! Jili Dong add support for regular lat lon (2019/03/22) start @@ -801,7 +802,7 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) if(numDims==1)then Status=nf90_get_var(ncid3d,varid,glat1d) do j=jsta,jend - do i=1,im + do i=ista,iend gdlat(i,j) = real(glat1d(j),kind=4) end do end do @@ -812,13 +813,13 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) if(maxval(abs(dummy))1.0E6 .or. pint(1,jsta_2l,lp1)<50000.) & + do i=ista,iend +! if(pint(i,j,lp1)>1.0E6 .or. pint(ista_2l,jsta_2l,lp1)<50000.) & ! print*,'bad psfc ',i,j,pint(i,j,lp1) end do end do @@ -1677,14 +1596,14 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) pt = ak5(1) do j=jsta,jend - do i=1,im + do i=ista,iend pint(i,j,1)= pt end do end do do l=2,lp1 do j=jsta,jend - do i=1,im + do i=ista,iend if (dpres(i,j,l-1) @file -! -!> SUBPROGRAM: INITPOST INITIALIZE POST FOR RUN -!! PRGRMMR: RUSS TREADON ORG: W/NP2 DATE: 93-11-10 -!! -!! ABSTRACT: THIS ROUTINE INITIALIZES CONSTANTS AND -!! VARIABLES AT THE START OF AN ETA MODEL OR POST -!! PROCESSOR RUN. -!! -!! THIS ROUTINE ASSUMES THAT INTEGERS AND REALS ARE THE SAME SIZE -!! -!! PROGRAM HISTORY LOG: -!! 93-11-10 RUSS TREADON - ADDED DOCBLOC -!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D -!! 99-01 20 TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! 02-08-15 H CHUANG - UNIT CORRECTION AND GENERALIZE PROJECTION OPTIONS -!! 03-07-25 H CHUANG - MODIFIED TO PROCESS NMM WRF -!! 05-12-05 H CHUANG - ADD CAPABILITY TO OUTPUT OFF-HOUR FORECAST WHICH HAS -!! NO INPACTS ON ON-HOUR FORECAST -!! 21-03-11 Bo Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL INIT -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOKUP -!! SOILDEPTH -!! -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! - SUBROUTINE INITPOST_NMM - - use vrbls3d, only: t, u, uh, v, vh, q, cwm, f_ice, f_rain, f_rimef, q,& - qqw, qqr, qqs, qqi, qqg, qqw, cwm , q2, wh, pint, alpint, pmid,& - omga, pmidv, zmid, rlwtt, rswtt, ttnd, tcucn, train, exch_h,& - el_pbl, cfr, zint, REF_10CM, qqni, qqnr, qrimef - use vrbls2d, only: fis, cfrach, cfracl, cfracm, u10h, u10, v10h, v10,th10,& - q10, tshltr, qshltr, pshltr, smstav, smstot, acfrcv, acfrst, ncfrcv,& - ncfrst, ssroff, bgroff, sfcevp, sfcexc, vegfrc, acsnow, acsnom,& - cmc, sst, mdltaux, mdltauy, thz0, qz0, uz0, vz0, qs, z0, pblh, mixht,& - ustar, akhs, akms, ths, prec, cuprec, acprec, ancprc, cprate, cuppt,& - lspa, cldefi, htop, hbot, htopd, czmean, rswout, rlwin, rlwtoa, sigt4,& - radot, aswin, aswout, alwin, alwout, alwtoa, aswtoa, hbotd, htops,& - hbots, sr, rswin, rswinc, czen, tg, soiltb, twbs, sfcshx, qwbs,& - sfclhx, grnflx, subshx, potevp, sno, si, pctsno, ivgtyp, isltyp,& - islope, albedo, albase, mxsnal, epsr, f, REFC_10CM, REFD_MAX, & - RSWTOA, SWUPT, ACSWUPT, SWDNT, ACSWDNT, CD10, CH10 - use soil, only: smc, sh2o, stc, sldpth, sllevel - use masks, only: lmv, lmh, htm, vtm, hbm2, sm, sice, gdlat, gdlon, dx, dy - use params_mod, only: tfrz, g, rd, d608, rtd, dtr, erad - use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl,& - qs0, sqs, sthe, the0, ttblq, rdpq, rdtheq, stheq, the0q - use ctlblk_mod, only: jsta, jend, nprec, jsta_2l, jend_2u, filename,& - datahandle, datestr, ihrst, imin, sdat, spval, imp_physics, pt,& - icu_physics, pdtop, nsoil, isf_surface_physics, jsta_m, jend_m,& - avrain, avcnvc, ardsw, ardlw, asrfc, me, mpi_comm_comp, nphs, spl,& - lsm, dt, dtq2,tsrfc, trdlw, trdsw, idat, ifhr, ifmin, restrt,& - theat, tclod, tprec, alsl, lm, im, jm , submodelname - use gridspec_mod, only: latstart, latlast, cenlat, lonstart, lonlast,& - cenlon, dxval, dyval, maptype, gridtype, truelat1, truelat2,& - psmapf -! use wrf_io_flags_mod -! - implicit none -! -! INCLUDE/SET PARAMETERS. -! - INCLUDE "mpif.h" -! -! This version of INITPOST shows how to initialize, open, read from, and -! close a NetCDF dataset. In order to change it to read an internal (binary) -! dataset, do a global replacement of _ncd_ with _int_. - real :: dcenlat, dcenlon - character(len=31) :: VarName - integer :: Status, cen1, cen2 - character startdate*19,SysDepInfo*80 -! -! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK -! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE. -! -! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE -! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE. - CHARACTER*4 RESTHR - INTEGER IDATE(8),JDATE(8) - INTEGER :: i_parent_start, j_parent_start -! -! DECLARE VARIABLES. -! - REAL RINC(5) - REAL ETA1(LM), ETA2(LM) - REAL DUMMY ( IM, JM ) -! REAL DUMMY2 ( IM, JM ) - real, allocatable :: fi(:,:,:) - REAL DUM3D ( IM+1, JM+1, LM+1 ) - REAL DUM3D2 ( IM+1, JM+1, LM+1 ) -!mp - INTEGER IDUMMY ( IM, JM ) -! -!jw - integer ii,jj,js,je,jev,iyear,imn,iday,itmp,ioutcount,istatus, & - nsrfc,nrdlw,nrdsw,nheat,nclod, & - I,J,L,LL,N,LONEND,LATEND,IMM,INAV,IRTN, & - IFDX,IFDY,IGDOUT,ICEN,JCEN -! integer iw, ie - real TSPH,fact,dumcst,tstart,tmp - real LAT -! -! Declarations for : -! putting 10 m wind on V points because copygb assume such - INTEGER IE, IW -!code from R.Rozumalski - INTEGER latnm, latsm, lonem, lonwm, idxave, dlat, dlon, nlat, nlon - -!*********************************************************************** -! START INIT HERE. -! - WRITE(6,*)'INITPOST: ENTER INITPOST' - print*,'im,jm,lm= ',im,jm,lm - - ii=im/2 ! diagnostic print indices - jj=(jsta+jend)/2 - ll=lm/2 -! -! STEP 1. READ MODEL OUTPUT FILE -! -! -!*** -! -! set default to not empty buket - NSRFC=0 - NRDLW=0 - NRDSW=0 - NHEAT=0 - NCLOD=0 - NPREC=0 - -! LMH always = LM for sigma-type vert coord -! LMV always = LM for sigma-type vert coord - - do j = jsta_2l, jend_2u - do i = 1, im - LMV ( i, j ) = lm - LMH ( i, j ) = lm - end do - end do - - -! HTM VTM all 1 for sigma-type vert coord - - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - HTM ( i, j, l ) = 1.0 - VTM ( i, j, l ) = 1.0 - end do - end do - end do -! -! how do I get the filename? -! fileName = '/ptmp/wx20mb/wrfout_01_030500' -! DateStr = '2002-03-05_18:00:00' -! how do I get the filename? - call ext_ncd_ioinit(SysDepInfo,Status) - print*,'called ioinit', Status - call ext_ncd_open_for_read( trim(fileName), 0, 0, " ", & - DataHandle, Status) - print*,'called open for read', Status - if ( Status /= 0 ) then - print*,'error opening ',fileName, ' Status = ', Status ; stop - endif -! get date/time info -! this routine will get the next time from the file, not using it - print *,'DateStr before calling ext_ncd_get_next_time=',DateStr -! call ext_ncd_get_next_time(DataHandle, DateStr, Status) - print *,'DateStri,Status,DataHandle = ',DateStr,Status,DataHandle - -! The end j row is going to be jend_2u for all variables except for V. - JS=JSTA_2L - JE=JEND_2U - IF (JEND_2U==JM) THEN - JEV=JEND_2U+1 - ELSE - JEV=JEND_2U - ENDIF -! -! Getting start time - call ext_ncd_get_dom_ti_char(DataHandle,'START_DATE',startdate, & - status ) -! patch for NMM WRF because it does not have start-date in output yet -! startdate='2003-04-17T00:00:00' - print*,'startdate= ',startdate -! - jdate=0 - idate=0 - read(startdate,15)iyear,imn,iday,ihrst,imin - 15 format(i4,1x,i2,1x,i2,1x,i2,1x,i2) - print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin - print*,'processing yr mo day hr min=',idat(3),idat(1),idat(2), & - idat(4),idat(5) - idate(1)=iyear - idate(2)=imn - idate(3)=iday - idate(5)=ihrst - idate(6)=imin - SDAT(1)=imn - SDAT(2)=iday - SDAT(3)=iyear -! - jdate(1)=idat(3) - jdate(2)=idat(1) - jdate(3)=idat(2) - jdate(5)=idat(4) - jdate(6)=idat(5) -! CALL W3DIFDAT(JDATE,IDATE,2,RINC) -! ifhr=nint(rinc(2)) - CALL W3DIFDAT(JDATE,IDATE,0,RINC) - ifhr=nint(rinc(2)+rinc(1)*24.) - ifmin=nint(rinc(3)) - print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,fileName - -! Getting tstart - call ext_ncd_get_dom_ti_real(DataHandle,'TSTART',tmp,1,ioutcount, & - istatus) - if(istatus==0)then - tstart=tmp - else - tstart=0. - end if - print*,'status for getting TSTART= ',istatus - print*,'TSTART= ',TSTART - -! Getting restart - - RESTRT=.TRUE. ! set RESTRT default - call ext_ncd_get_dom_ti_integer(DataHandle,'RESTARTBIN',itmp,1, & - ioutcount,istatus) - - IF(itmp < 1)THEN - RESTRT=.FALSE. - ELSE - RESTRT=.TRUE. - END IF - - print*,'status for getting RESTARTBIN= ',istatus - print*,'Is this a restrt run? ',RESTRT - -! IF(RESTRT)THEN -! ifhr=ifhr+NINT(tstart) -! print*,'new forecast hours for restrt run= ',ifhr -! END IF - - IF(tstart > 1.0E-2)THEN - ifhr=ifhr+NINT(tstart) - rinc=0 - idate=0 - rinc(2)=-1.0*ifhr - call w3movdat(rinc,jdate,idate) - SDAT(1)=idate(2) - SDAT(2)=idate(3) - SDAT(3)=idate(1) - IHRST=idate(5) - print*,'new forecast hours for restrt run= ',ifhr - print*,'new start yr mo day hr min =',sdat(3),sdat(1), & - sdat(2),ihrst,imin - END IF - - VarName='HBM2' - HBM2=SPVAL - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBM2 ( i, j ) = dummy ( i, j ) - end do - end do - -! OK, since all of the variables are dimensioned/allocated to be -! the same size, this means we have to be careful int getVariable -! to not try to get too much data. For example, -! DUM3D is dimensioned IM+1,JM+1,LM+1 but there might actually -! only be im,jm,lm points of data available for a particular variable. - -! get 3-D variables - VarName='T' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - t ( i, j, l ) = dum3d ( i, j, l ) -! if(l==1)print*,'Debug: I,J,T= ',i,j,t ( i, j, l ) -! t ( i, j, l ) = dum3d ( i, j, l ) + 300. -! th ( i, j, l ) = dum3d ( i, j, l ) + 300. - end do - end do - end do - do l=1,lm - if(jj>= jsta .and. jj<=jend)print*,'sample L,T= ',L,T(ii,jj,l) - end do - -! VarName='T_ADJ' -! call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, -! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM) -! do l = 1, lm -! do j = jsta_2l, jend_2u -! do i = 1, im -! t_ADJ ( i, j, l ) = dum3d ( i, j, l ) -! end do -! end do -! end do -! do l=1,lm -! if(jj>= jsta .and. jj<=jend)print*,'sample L,T_ADJ= ',L -! &,T_ADJ(ii,jj,l) -! end do - - - VarName='U' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - u ( i, j, l ) = dum3d ( i, j, l ) - UH( i, j, l ) = dum3d ( i, j, l ) -! if(l==1)print*,'Debug: I,J,U= ',i,j,u( i, j, l ) - end do - end do -! fill up UH which is U at P-points including 2 row halo -! do j = jsta_2l, jend_2u -! do i = 1, im -! UH (I,J,L) = (dum3d(I,J,L)+dum3d(I+1,J,L))*0.5 -! end do -! end do - end do - if(jj>= jsta .and. jj<=jend)print*,'sample U= ',U(ii,jj,ll) - VarName='V' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - v ( i, j, l ) = dum3d ( i, j, l ) - VH( i, j, l ) = dum3d ( i, j, l ) - end do - end do -! fill up VH which is V at P-points including 2 row halo -! do j = jsta_2l, jend_2u -! do i = 1, im -! VH(I,J,L) = (dum3d(I,J,L)+dum3d(I,J+1,L))*0.5 -! end do -! end do - end do - if(jj>= jsta .and. jj<=jend)print*,'sample V= ',V(ii,jj,ll) - - call ext_ncd_get_dom_ti_integer(DataHandle,'MP_PHYSICS' & - ,itmp,1,ioutcount,istatus) - imp_physics=itmp -! Chuang: will initialize microphysics constants differently for 85 now -! if(imp_physics == 85) imp_physics=5 !HWRF - print*,'MP_PHYSICS= ',imp_physics - -! Initializes constants for Ferrier microphysics - if(imp_physics==5 .or. imp_physics==15 .or. imp_physics==85 & - .or. imp_physics==95)then - CALL MICROINIT(imp_physics) - end if - - call ext_ncd_get_dom_ti_integer(DataHandle,'CU_PHYSICS' & - ,itmp,1,ioutcount,istatus) - icu_physics=itmp - if (icu_physics == 84 .or. icu_physics == 85) icu_physics = 4 ! HWRF - print*,'CU_PHYSICS= ',icu_physics - - ! Set these values to SPVAL to insure they are initialized a - ! fact that the code relies on later.... - qqw=spval - qqr=spval - qqs=spval - qqi=spval - qqg=spval - -!KRF: NMM and ARW direct read of radar ref for microphysic options -! mp options: 2,4,6,7,8,10,14,16 -! REFL_10cm --> REF_10CM -! REFD_MAX --> REFD_MAX - VarName='REFL_10CM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - REF_10CM ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - do l=1,lm - if(jj>= jsta .and. jj<=jend)print*,'sample L,T= ',L,T(ii,jj,l) - end do - - VarName='REFD_MAX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - REFD_MAX ( i, j ) = dummy ( i, j ) - end do - end do -! print*,'REFD_MAX at ',ii,jj,' = ',REFD_MAX(ii,jj) -! END KRF - - if(imp_physics==5 .or. imp_physics==15 .or. imp_physics==85 .or. imp_physics==95)then - - VarName='Q' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - if (dum3d(i,j,l) < 10E-12) dum3d(i,j,l) = 10E-12 - q ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - print*,'finish reading specific humidity' - if(jj>= jsta .and. jj<=jend)print*,'sample Q= ',Q(ii,jj,ll) - - else - VarName='QVAPOR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im -! q ( i, j, l ) = dum3d ( i, j, l ) -! if(l==1)print*,'Debug: I,J,Q= ',i,j,q( i, j, l ) -!CHC CONVERT MIXING RATIO TO SPECIFIC HUMIDITY - if (dum3d(i,j,l) < 10E-12) dum3d(i,j,l) = 10E-12 - q ( i, j, l ) = dum3d ( i, j, l )/(1.0+dum3d ( i, j, l )) - end do - end do - end do - print*,'finish reading specific humidity' - if(jj>= jsta .and. jj<=jend)print*,'sample Q= ',Q(ii,jj,ll) - endif - - if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then - VarName='CWM' !????? - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - cwm ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - print*,'finish reading cloud mixing ratio' - - VarName='F_ICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - F_ICE ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - VarName='F_RAIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - F_RAIN ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - VarName='F_RIMEF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - F_RIMEF ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - else ! retrieve hydrometeo fields directly for non-Ferrier - cwm=spval !make sure set - F_RimeF=spval !make sure set - - if(imp_physics/=0)then - VarName='QCLOUD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im -! partition cloud water and ice for WSM3 - if(imp_physics==3)then - if(t(i,j,l) >= TFRZ)then - qqw ( i, j, l ) = dum3d ( i, j, l ) - else - qqi ( i, j, l ) = dum3d ( i, j, l ) - end if - else ! bug fix provided by J CASE - qqw ( i, j, l ) = dum3d ( i, j, l ) - end if - cwm(i,j,l)=dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqw= ' & - ,Qqw(ii,jj,ll) - - if(imp_physics/=1 .and. imp_physics/=3 & - .and. imp_physics/=0)then - VarName='QICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqi ( i, j, l ) = dum3d ( i, j, l ) - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqi= ' & - ,Qqi(ii,jj,ll) - - if(imp_physics==15) then - VarName='QRIMEF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qrimef ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qrimef= ' & - ,Qrimef(ii,jj,ll) - - if(imp_physics/=0)then - VarName='QRAIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im -! partition rain and snow for WSM3 - if(imp_physics == 3)then - if(t(i,j,l) >= TFRZ)then - qqr ( i, j, l ) = dum3d ( i, j, l ) - else - qqs ( i, j, l ) = dum3d ( i, j, l ) - end if - else ! bug fix provided by J CASE - qqr ( i, j, l ) = dum3d ( i, j, l ) - end if - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqr= ' & - ,Qqr(ii,jj,ll) - - if(imp_physics/=1 .and. imp_physics/=3 & - .and. imp_physics/=0)then - VarName='QSNOW' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqs ( i, j, l ) = dum3d ( i, j, l ) - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqs= ' & - ,Qqs(ii,jj,ll) - - if(imp_physics==2 .or. imp_physics==6 & - .or. imp_physics==8 .or. imp_physics==28)then - VarName='QGRAUP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqg ( i, j, l ) = dum3d ( i, j, l ) - cwm(i,j,l)=cwm(i,j,l)+dum3d(i,j,l) - end do - end do - end do - end if - if(jj>= jsta .and. jj<=jend)print*,'sample qqg= ' & - ,Qqg(ii,jj,ll) - -! KRS: Add concentrations for HWRF output - if(imp_physics==8 .or. imp_physics==9)then - VarName='QNICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM, JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqni ( i, j, l ) = dum3d ( i, j, l ) - if(i==im/2.and.j==(jsta+jend)/2)print*,'sample QQNI= ', & - i,j,l,QQNI ( i, j, l ) - end do - end do - end do - VarName='QNRAIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM, JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - qqnr ( i, j, l ) = dum3d ( i, j, l ) - if(i==im/2.and.j==(jsta+jend)/2)print*,'sample QQNR= ', & - i,j,l,QQNR ( i, j, l ) - end do - end do - end do - end if -! KRS: End add concentrations for HWRF - - end if ! end of retrieving hydrometeo for different MP options - - -! call getVariable(fileName,DateStr,DataHandle,'TKE_PBL',DUM3D, - call getVariable(fileName,DateStr,DataHandle,'Q2',DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - q2 ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - VarName='W' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM+1) -! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM) -! do l = 1, lm+1 -! do j = jsta_2l, jend_2u -! do i = 1, im -! w ( i, j, l ) = dum3d ( i, j, l ) -! end do -! end do -! end do -! fill up WH which is W at P-points including 2 row halo - DO L=1,LM - DO I=1,IM - DO J=JSTA_2L,JEND_2U -! WH(I,J,L) = (W(I,J,L)+W(I,J,L+1))*0.5 - wh ( i, j, l ) = dum3d ( i, j, l+1 ) - ENDDO - ENDDO - ENDDO - print*,'finish reading W' - -!MEB call getVariable(fileName,DateStr,DataHandle,'QRAIN',new) - - VarName='PINT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM+1) -! VarName='P' -! call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D2, -! & IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm+1 - do j = jsta_2l, jend_2u - do i = 1, im -! PMID(I,J,L)=DUM3D(I,J,L)+DUM3D2(I,J,L) - PINT(I,J,L)=DUM3D(I,J,L) - ALPINT(I,J,L)=ALOG(PINT(I,J,L)) - end do - end do - end do -! do l = 1, lm+1 -! if(jj>= jsta .and. jj<=jend)print*,'sample PINT= ' -! & ,PINT(ii,jj,l) -! end do -! - DO L=1,LM - DO I=1,IM - DO J=JSTA_2L,JEND_2U - PMID(I,J,L)=(PINT(I,J,L)+PINT(I,J,L+1))*0.5 -! TH(I,J,L)=T(I,J,L)*(1.E5/PMID(I,J,L))**CAPA - IF(ABS(T(I,J,L))>1.0E-3) & - OMGA(I,J,L) = -WH(I,J,L)*PMID(I,J,L)*G/ & - (RD*T(I,J,L)*(1.+D608*Q(I,J,L))) -! -! PINT(I,J,L)=EXP((ALOG(PMID(I,J,L-1))+ -! & ALOG(PMID(I,J,L)))*0.5) ! ave of ln p -! ALPINT(I,J,L)=ALOG(PINT(I,J,L)) - ENDDO - ENDDO - ENDDO -! - do l = 1, lm - do j = jsta, jend - do i = 1, im-MOD(J,2) - IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC - PMIDV(I,J,L)=0.5*(PMID(I,J,L)+PMID(I+1,J,L)) - ELSE IF(J==JM .AND. I1.0e-5)print*,'nonzero ncfrcv',ncfrcv(i,j) - end do - end do - - VarName='NCFRST' - write(6,*) 'call getIVariable for : ', VarName - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ncfrst ( i, j ) = float(idummy ( i, j )) -! if(ncfrst(i,j)>1.0e-5)print*,'nonzero ncfrst',ncfrst(i,j) - end do - end do - - VarName='SSROFF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SSROFF ( i, j ) = dummy ( i, j ) - end do - end do - VarName='UDROFF' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - BGROFF ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SFCEVP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCEVP( i, j ) = dummy ( i, j ) - end do - end do -! print*,'SFCEVP at ',ii,jj,' = ',SFCEVP(ii,jj) - - VarName='CD10' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY,& - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CD10( i, j ) = dummy ( i, j ) - end do - end do -! print*,'CD10 at ',ii,jj,' = ',CD10(ii,jj) - - VarName='CH10' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY,& - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CH10( i, j ) = dummy ( i, j ) - end do - end do -! print*,'CD10 at ',ii,jj,' = ',CD10(ii,jj) - - VarName='SFCEXC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCEXC( i, j ) = dummy ( i, j ) - end do - end do -! print*,'SFCEXC at ',ii,jj,' = ',SFCEXC(ii,jj) - VarName='VEGFRC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - VEGFRC ( i, j ) = dummy ( i, j ) - end do - end do - print*,'VEGFRC at ',ii,jj,' = ',VEGFRC(ii,jj) - VarName='ACSNOW' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSNOW ( i, j ) = dummy ( i, j ) - end do - end do - VarName='ACSNOM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSNOM ( i, j ) = dummy ( i, j ) - end do - end do -! VarName='CANWAT' - VarName='CMC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CMC ( i, j ) = dummy ( i, j ) - end do - end do - VarName='SST' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SST ( i, j ) = dummy ( i, j ) - end do - end do - print*,'SST at ',ii,jj,' = ',sst(ii,jj) - - VarName='TAUX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MDLTAUX ( i, j ) = dummy ( i, j ) - end do - end do - print*,'MDLTAUX at ',ii,jj,' = ',mdltaux(ii,jj) - - VarName='TAUY' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MDLTAUY ( i, j ) = dummy ( i, j ) - end do - end do - print*,'MDLTAUY at ',ii,jj,' = ',mdltauy(ii,jj) - - VarName='EXCH_H' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - EXCH_H ( i, j, l ) = dum3d ( i, j, l ) - dummy(i,j)=dum3d ( i, j, l ) - end do - end do - print*,'l, max exch = ',l,maxval(dummy) - end do - do l=1,lm - print*,'sample EXCH_H= ',EXCH_H(ii,jj,l) - end do - - VarName='EL_PBL' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - EL_PBL ( i, j, l ) = dum3d ( i, j, l ) - dummy(i,j)=dum3d ( i, j, l ) - end do - end do - print*,'l, max EL_PBL = ',l,maxval(dummy) - end do - - - VarName='THZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - THZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'THZ0 at ',ii,jj,' = ',THZ0(ii,jj) - VarName='QZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - QZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'QZ0 at ',ii,jj,' = ',QZ0(ii,jj) - VarName='UZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - UZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'UZ0 at ',ii,jj,' = ',UZ0(ii,jj) - VarName='VZ0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - VZ0 ( i, j ) = dummy ( i, j ) - end do - end do - print*,'VZ0 at ',ii,jj,' = ',VZ0(ii,jj) -! VarName='QSFC' - VarName='QS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - QS ( i, j ) = dummy ( i, j ) -! if(qs(i,j)>1.0e-7)print*,'nonzero qsfc' - end do - end do - - VarName='Z0' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - Z0 ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='PBLH' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - PBLH( i, j ) = dummy ( i, j ) - end do - end do -! write(6,*) 'PBLH(ii,jj): ', DUMMY(ii,jj) - - VarName='MIXHT' !PLee (3/07) - MIXHT=SPVAL !Init value to detect read failure - call getVariable(filename,DateStr,DataHandle,Varname,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MIXHT( i, j ) = dummy ( i, j ) - end do - end do - - VarName='USTAR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - USTAR( i, j ) = dummy ( i, j ) - end do - end do - - print*,'USTAR at ',ii,jj,' = ',USTAR(ii,jj) - VarName='AKHS_OUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - AKHS ( i, j ) = dummy ( i, j ) - end do - end do - print*,'max akhs= ',maxval(akhs) - VarName='AKMS_OUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - AKMS ( i, j ) = dummy ( i, j ) - end do - end do - print*,'max akms= ',maxval(akms) - -! -! In my version, variable is TSK (skin temp, not skin pot temp) -! -!mp call getVariable(fileName,DateStr,DataHandle,'THSK',DUMMY, -! VarName='TSK' - VarName='THS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - THS ( i, j ) = dummy ( i, j ) - end do - end do - print*,'THS at ',ii,jj,' = ',THS(ii,jj) - -!C -!CMP -!C -!C RAINC is "ACCUMULATED TOTAL CUMULUS PRECIPITATION" -!C RAINNC is "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" - - write(6,*) 'getting RAINC' - - VarName='PREC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im -! CUPREC ( i, j ) = dummy ( i, j ) * 0.001 - PREC ( i, j ) = dummy ( i, j ) - end do - end do - print*,'PREC at ',ii,jj,' = ',PREC(ii,jj) - -! VarName='RAINC' - VarName='CUPREC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im -! CUPREC ( i, j ) = dummy ( i, j ) * 0.001 - CUPREC ( i, j ) = dummy ( i, j ) - end do - end do - print*,'CUPREC at ',ii,jj,' = ',CUPREC(ii,jj) - write(6,*) 'getting RAINTOTAL' -! VarName='RAINNC' - VarName='ACPREC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACPREC( i, j ) = dummy ( i, j ) - ANCPRC ( i, j ) = ACPREC(I,J)-CUPREC(I,J) - end do - end do - print*,'ACPREC at ',ii,jj,' = ',ACPREC(ii,jj) - print*,'ANCPRC at ',ii,jj,' = ',ANCPRC(ii,jj) -! -! hoping to read instantanous convective precip rate soon, initialize it to spval -! for now - - VarName='CPRATE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CPRATE(I,J)=dummy(i,j) - enddo - enddo - - VarName='CUPPT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CUPPT ( i, j ) = dummy ( i, j ) - end do - end do - print*,'maxval CUPPT: ', maxval(DUMMY) - -! adding land surface precipitation accumulation for Yin's precip assimilation - - VarName='LSPA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - LSPA ( i, j ) = dummy ( i, j ) - end do - end do - print*,'maxval LSPA: ', maxval(DUMMY) - - - VarName='CLDEFI' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CLDEFI ( i, j ) = dummy ( i, j ) - end do - end do - print*,'maxval CLDEFI: ', maxval(DUMMY) - -! -! Very confusing story ... -! -! Retrieve htop and hbot => They are named CNVTOP, CNVBOT in the model and -! with HBOTS,HTOPS (shallow conv) and HBOTD,HTOPD (deep conv) represent -! the 3 sets of convective cloud base/top arrays tied to the frequency -! that history files are written. -! -! IN THE *MODEL*, arrays HBOT,HTOP are similar to CNVTOP,CNVBOT but are -! used in radiation and are tied to the frequency of radiation updates. -! -! For historical reasons model arrays CNVTOP,CNVBOT are renamed HBOT,HTOP -! and manipulated throughout the post. - -! VarName='HTOP' - VarName='CNVTOP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HTOP ( i, j ) = float(LM)-dummy(i,j)+1.0 - HTOP ( i, j ) = max(1.0,min(HTOP(I,J),float(LM))) - end do - end do - print*,'maxval HTOP: ', maxval(DUMMY) - -! VarName='HBOT' - VarName='CNVBOT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBOT ( i, j ) = float(LM)-dummy(i,j)+1.0 - HBOT ( i, j ) = max(1.0,min(HBOT(I,J),float(LM))) - end do - end do - print*,'maxval HBOT: ', maxval(DUMMY) - - VarName='HTOPD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HTOPD ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HTOPD: ', maxval(DUMMY) - - VarName='HBOTD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBOTD ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HBOTD: ', maxval(DUMMY) - - VarName='HTOPS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HTOPS ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HTOPS: ', maxval(DUMMY) - - VarName='HBOTS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - HBOTS ( i, j ) = float(LM)-dummy(i,j)+1.0 - end do - end do - print*,'maxval HBOTS: ', maxval(DUMMY) - - VarName='CLDFRA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUM3D, & - IM+1,1,JM+1,LM+1,IM,JS,JE,LM) - do l = 1, lm - do j = jsta_2l, jend_2u - do i = 1, im - CFR ( i, j, l ) = dum3d ( i, j, l ) - end do - end do - end do - - - VarName='SR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SR ( i, j ) = dummy(i,j) - end do - end do - print*,'maxval SR: ', maxval(DUMMY) - -! call getVariable(fileName,DateStr,DataHandle,'RAINCV',DUMMY, -! & IM,1,JM,1,IM,JS,JE,1) -! do j = jsta_2l, jend_2u -! do i = 1, im -! CUPPT ( i, j ) = dummy ( i, j )* 0.001 -! end do -! end do -! -! VarName='GSW' - VarName='RSWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWIN ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'rswin=',dummy(i,j) - end do - end do - - VarName='RSWINC' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWINC ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'rswin=',dummy(i,j) - end do - end do - -! read in zenith angle - VarName='CZEN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CZEN ( i, j ) = dummy ( i, j ) -! if(abs(czen(i,j))> 0.0)print*,'czen=',czen(i,j) - end do - end do - - VarName='CZMEAN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - CZMEAN ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'czmean=',dummy(i,j) - end do - end do - - VarName='RSWOUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWOUT ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'rswout=',dummy(i,j) - end do - end do - -! VarName='GLW' - VarName='RLWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RLWIN ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='RLWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RLWTOA ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SIGT4' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SIGT4 ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='RADOT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RADOT ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated incoming short wave - VarName='ASWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ASWIN ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated outgoing short wave - VarName='ASWOUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ASWOUT ( i, j ) = dummy ( i, j ) -! if(abs(dummy(i,j))> 0.0)print*,'aswout=',dummy(i,j) - end do - end do - -! shortwave accumulation frequency - VarName='NRDSW' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NRDSW, & - 1,1,1,1,1,1,1,1) - print*,'NRDSW in INITPOST_NMM=',NRDSW - - VarName='ARDSW' - call getVariable(fileName,DateStr,DataHandle,VarName,ARDSW, & - 1,1,1,1,1,1,1,1) - print*,'ARDSW ARDLW in INITPOST_NMM=',ARDSW, ARDLW -! accumulated incoming long wave - VarName='ALWIN' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALWIN ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated outgoing long wave - VarName='ALWOUT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALWOUT ( i, j ) = dummy ( i, j ) - end do - end do - -! longwave accumulation frequency - VarName='NRDLW' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NRDLW, & - 1,1,1,1,1,1,1,1) - print*,'NRDLW= ',NRDLW - -! longwave accumulation counts - VarName='ARDLW' - call getVariable(fileName,DateStr,DataHandle,VarName,ARDLW, & - 1,1,1,1,1,1,1,1) - -! obtain time averaged radition at the top of atmosphere - VarName='ALWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALWTOA ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ASWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ASWTOA ( i, j ) = dummy ( i, j ) - end do - end do - -! KRS: Add RSWTOA to radiation variable options - VarName='RSWTOA' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - RSWTOA ( i, j ) = dummy ( i, j ) - end do - end do - -! KRS: RRTMG variables for HWRF - VarName='SWUPT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SWUPT ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ACSWUPT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSWUPT ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SWDNT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SWDNT ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ACSWDNT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ACSWDNT ( i, j ) = dummy ( i, j ) - end do - end do - -! END KRS RRTMG Vars - - -! VarName='TMN' -! VarName='TG' - VarName='TGROUND' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - TG ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SOILTB' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SOILTB ( i, j ) = dummy ( i, j ) - end do - end do - -! sensible heat fluxes - VarName='TWBS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - TWBS ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated sensible heat fluxes -! VarName='HFX' - VarName='SFCSHX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCSHX ( i, j ) = dummy ( i, j ) - end do - end do - -! fluxes accumulation frequency - VarName='NSRFC' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NSRFC, & - 1,1,1,1,1,1,1,1) - print*,'NSRFC= ',NSRFC -! fluxes accumulation counts - VarName='ASRFC' - call getVariable(fileName,DateStr,DataHandle,VarName,ASRFC, & - 1,1,1,1,1,1,1,1) - -! instantanous latent heat fluxes - VarName='QWBS' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - QWBS ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated latent heat fluxes -! VarName='QFX' - VarName='SFCLHX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SFCLHX ( i, j ) = dummy ( i, j ) - end do - end do - -! instantanous ground heat fluxes - VarName='GRNFLX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - GRNFLX ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated ground heat fluxes - VarName='SUBSHX' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SUBSHX ( i, j ) = dummy ( i, j ) - end do - end do - -! accumulated ground heat fluxes - VarName='POTEVP' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - POTEVP ( i, j ) = dummy ( i, j ) - end do - end do - -! VarName='SNOWC' -! VarName='SNO' - VarName='WEASD' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) -! do j = jsta_2l, jend_2u -! do i = 1, im -! SNO ( i, j ) = dummy ( i, j ) -! end do -! end do - - VarName='SNO' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SNO ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SI' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SI ( i, j ) = dummy ( i, j ) - end do - end do - -! snow cover - VarName='PCTSNO' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - PCTSNO ( i, j ) = dummy ( i, j ) - if(dummy(i,j) > 1.0e-5)print*,'nonzero pctsno' - end do - end do - - -! GET VEGETATION TYPE - -! call getVariable(fileName,DateStr,DataHandle,'IVGTYP',DUMMY -! & ,IM,1,JM,1,IM,JS,JE,1) -! print*,'sample VEG TYPE',DUMMY(20,20) -! XLAND 1 land 2 sea -! VarName='XLAND' - - VarName='IVGTYP' - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - IVGTYP ( i, j ) = idummy ( i, j ) - end do - end do - print*,'MAX IVGTYP=', maxval(idummy) - - VarName='ISLTYP' - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ISLTYP ( i, j ) = idummy ( i, j ) - end do - end do - print*,'MAX ISLTYP=', maxval(idummy) - - VarName='ISLOPE' - call getIVariableN(fileName,DateStr,DataHandle,VarName,IDUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ISLOPE( i, j ) = idummy ( i, j ) - end do - end do - - VarName='SM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SM ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='SICE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - SICE ( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ALBEDO' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALBEDO( i, j ) = dummy ( i, j ) - end do - end do - - VarName='ALBASE' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - ALBASE( i, j ) = dummy ( i, j ) - end do - end do - - VarName='MXSNAL' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - MXSNAL( i, j ) = dummy ( i, j ) - end do - end do - - VarName='EPSR' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - EPSR( i, j ) = dummy ( i, j ) - end do - end do - -! VarName='XLAT' - VarName='GLAT' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - f(i,j) = 1.454441e-4*sin(dummy(i,j)) - GDLAT ( i, j ) = dummy ( i, j ) * RTD - end do - end do -! pos north - print*,'GDLAT at ',ii,jj,' = ',GDLAT(ii,jj) - print*,'read past GDLAT' -! VarName='XLONG' - VarName='GLON' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - GDLON ( i, j ) = dummy ( i, j ) * RTD -! if(j==1 .or. j==jm)print*,'I,J,GDLON,GDLAT= ',i,j -! 1 ,GDLON( i, j ),GDLAT ( i, j ) -! if(abs(GDLAT(i,j)-20.0)<0.5 .and. abs(GDLON(I,J) -! 1 +157.0)<5.)print* -! 2 ,'Debug:I,J,GDLON,GDLAT,SM,HGT,psfc= ',i,j,GDLON(i,j) -! 3 ,GDLAT(i,j),SM(i,j),FIS(i,j)/G,PINT(I,j,lm+1) - end do - end do - print*,'GDLON at ',ii,jj,' = ',GDLON(ii,jj) - print*,'read past GDLON' -! pos east - call collect_loc(gdlat,dummy) - get_dcenlat: if(me==0)then - latstart=nint(dummy(1,1)*1000.) ! lower left - latlast=nint(dummy(im,jm)*1000.) ! upper right - - icen=im/2 !center grid - jcen=jm/2 -print *, 'dummy(icen,jcen) = ', dummy(icen,jcen) -print *, 'dummy(icen-1,jcen) = ', dummy(icen-1,jcen) -print *, 'dummy(icen+1,jcen) = ', dummy(icen+1,jcen) - - ! Grid navigation for copygb - R.Rozumalski - latnm = nint(dummy(icen,jm)*1000.) - latsm = nint(dummy(icen,1)*1000.) -print *, 'latnm, latsm', latnm, latsm - - ! temporary patch for nmm wrf for moving nest - ! cenlat = glat(im/2,jm/2) -Gopal - - if(mod(im,2)/=0)then !per Pyle, jm is always odd - if(mod(jm+1,4)/=0)then - dcenlat=dummy(icen,jcen) - else - dcenlat=0.5*(dummy(icen-1,jcen)+dummy(icen,jcen)) - end if - else - if(mod(jm+1,4)/=0)then - dcenlat=0.5*(dummy(icen,jcen)+dummy(icen+1,jcen)) - else - dcenlat=dummy(icen,jcen) - end if - end if - endif get_dcenlat - write(6,*) 'laststart,latlast,dcenlat B calling bcast= ', & - latstart,latlast,dcenlat - call mpi_bcast(latstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(latlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(dcenlat,1,MPI_REAL,0,mpi_comm_comp,irtn) - write(6,*) 'laststart,latlast A calling bcast= ',latstart,latlast - - call collect_loc(gdlon,dummy) - get_dcenlon: if(me==0)then - lonstart=nint(dummy(1,1)*1000.) - lonlast=nint(dummy(im,jm)*1000.) - - ! icen, jcen set above -print *, 'lon dummy(icen,jcen) = ', dummy(icen,jcen) -print *, 'lon dummy(icen-1,jcen) = ', dummy(icen-1,jcen) -print *, 'lon dummy(icen+1,jcen) = ', dummy(icen+1,jcen) - - ! Grid navigation for copygb - R.Rozumalski - lonem = nint(dummy(icen,jm)*1000.) - lonwm = nint(dummy(icen,1)*1000.) - - if(mod(im,2)/=0)then !per Pyle, jm is always odd - if(mod(jm+1,4)/=0)then - cen1=dummy(icen,jcen) - cen2=cen1 - else - cen1=min(dummy(icen-1,jcen),dummy(icen,jcen)) - cen2=max(dummy(icen-1,jcen),dummy(icen,jcen)) - end if - else - if(mod(jm+1,4)/=0)then - cen1=min(dummy(icen+1,jcen),dummy(icen,jcen)) - cen2=max(dummy(icen+1,jcen),dummy(icen,jcen)) - else - cen1=dummy(icen,jcen) - cen2=cen1 - end if - end if - ! Trahan fix: Pyle's code broke at the dateline. - if(cen2-cen1>180) then - ! We're near the dateline - dcenlon=mod(0.5*(cen2+cen1+360)+3600+180,360.)-180. - else - ! We're not near the dateline. Use the original code, - ! unmodified, to maintain bitwise identicality. - dcenlon=0.5*(cen1+cen2) - endif - end if get_dcenlon ! rank 0 - write(6,*)'lonstart,lonlast,cenlon B calling bcast= ',lonstart, & - lonlast,cenlon - call mpi_bcast(lonstart,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(lonlast,1,MPI_INTEGER,0,mpi_comm_comp,irtn) - call mpi_bcast(dcenlon,1,MPI_REAL,0,mpi_comm_comp,irtn) - write(6,*)'lonstart,lonlast,cenlon A calling bcast= ',lonstart, & - lonlast,cenlon - - if(me==0) then - open(1013,file='this-domain-center.ksh.inc',form='formatted',status='unknown') -1013 format(A,'=',F0.3) - write(1013,1013) 'clat',dcenlat - write(1013,1013) 'clon',dcenlon - endif -! -! OBTAIN DX FOR NMM WRF - VarName='DX_NMM' - call getVariable(fileName,DateStr,DataHandle,VarName,DUMMY, & - IM,1,JM,1,IM,JS,JE,1) - do j = jsta_2l, jend_2u - do i = 1, im - DX ( i, j ) = dummy ( i, j ) - if(DX(i,j)<0.1)print*,'zero dx in INIT: I,J,DX= ',i,j & - ,DX( i, j ) -! if(j==1 .or. j==jm)print*,'I,J,DX= ',i,j -! 1 ,DX( i, j ) - end do - end do - - varname='ETA1' - write(6,*) 'call getVariable for : ', VarName - call getVariable(fileName,DateStr,DataHandle,VarName,ETA1, & - LM,1,1,1,LM,1,1,1) - - varname='ETA2' - write(6,*) 'call getVariable for : ', VarName - call getVariable(fileName,DateStr,DataHandle,VarName,ETA2, & - LM,1,1,1,LM,1,1,1) - - open(75,file='ETAPROFILE.txt',form='formatted',status='unknown') - DO L=1,lm+1 - IF(L == 1)THEN - write(75,1020)L, 0., 0. - ELSE - write(75,1020)L, ETA1(lm+2-l), ETA2(lm+2-l) - END IF -! print*,'L, ETA1, ETA2= ',L, ETA1(l), ETA2(l) - END DO - 1020 format(I3,2E17.10) - close (75) - -! physics calling frequency - VarName='NPHS0' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NPHS, & - 1,1,1,1,1,1,1,1) - print*,'NPHS= ',NPHS -! physics calling frequency - VarName='NCLOD' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NCLOD, & - 1,1,1,1,1,1,1,1) - -! physics calling frequency - VarName='NPREC' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NPREC, & - 1,1,1,1,1,1,1,1) - -! physics calling frequency - VarName='NHEAT' - call getIVariableN(fileName,DateStr,DataHandle,VarName,NHEAT, & - 1,1,1,1,1,1,1,1) - print*,'NHEAT= ',NHEAT - - ! Compute f_* arrays from q* arrays - if(imp_physics==15) then - print *,'Convert from Q arrays to F arrays for advected Ferrier.' - call etamp_q2f(QRIMEF,QQI,QQR,QQW,CWM,F_RAIN,F_ICE,F_RIMEF,T) - endif -! -! ncdump -h - -!! -!! -!! - write(6,*) 'filename in INITPOST=', filename,' is' - -! status=nf_open(filename,NF_NOWRITE,ncid) -! write(6,*) 'returned ncid= ', ncid -! status=nf_get_att_real(ncid,varid,'DX',tmp) -! dxval=int(tmp) -! status=nf_get_att_real(ncid,varid,'DY',tmp) -! dyval=int(tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LAT',tmp) -! cenlat=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'CEN_LON',tmp) -! cenlon=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT1',tmp) -! truelat1=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'TRUELAT2',tmp) -! truelat2=int(1000.*tmp) -! status=nf_get_att_real(ncid,varid,'MAP_PROJ',tmp) -! maptype=int(tmp) -! status=nf_close(ncid) - -! dxval=30000. -! dyval=30000. -! -! write(6,*) 'dxval= ', dxval -! write(6,*) 'dyval= ', dyval -! write(6,*) 'cenlat= ', cenlat -! write(6,*) 'cenlon= ', cenlon -! write(6,*) 'truelat1= ', truelat1 -! write(6,*) 'truelat2= ', truelat2 -! write(6,*) 'maptype is ', maptype -! - call ext_ncd_get_dom_ti_real(DataHandle,'DX',tmp, & - 1,ioutcount,istatus) - dxval=nint(tmp*1000.) ! E-grid dlamda in degree - write(6,*) 'dxval= ', dxval - - call ext_ncd_get_dom_ti_real(DataHandle,'DY',tmp, & - 1,ioutcount,istatus) - dyval=nint(tmp*1000.) - write(6,*) 'dyval= ', dyval - - call ext_ncd_get_dom_ti_real(DataHandle,'CEN_LAT',tmp, & - 1,ioutcount,istatus) - cenlat=nint(tmp*1000.) ! E-grid dlamda in degree - write(6,*) 'cenlat= ', cenlat - - call ext_ncd_get_dom_ti_real(DataHandle,'CEN_LON',tmp, & - 1,ioutcount,istatus) - cenlon=nint(tmp*1000.) ! E-grid dlamda in degree - write(6,*) 'cenlon= ', cenlon - -! JW call ext_ncd_get_dom_ti_real(DataHandle,'TRUELAT1',tmp -! JW + ,1,ioutcount,istatus) -! JW truelat1=nint(1000.*tmp) -! JW write(6,*) 'truelat1= ', truelat1 -! JW call ext_ncd_get_dom_ti_real(DataHandle,'TRUELAT2',tmp -! JW + ,1,ioutcount,istatus) -! JW truelat2=nint(1000.*tmp) -! JW write(6,*) 'truelat2= ', truelat2 - call ext_ncd_get_dom_ti_integer(DataHandle,'MAP_PROJ',itmp, & - 1,ioutcount,istatus) - maptype=itmp - gridtype = 'E' - write(6,*) 'maptype, gridtype ', maptype, gridtype - gridtype='E' - - call ext_ncd_get_dom_ti_integer(DataHandle,'I_PARENT_START',itmp, & - 1,ioutcount,istatus) - i_parent_start=itmp - - call ext_ncd_get_dom_ti_integer(DataHandle,'J_PARENT_START',itmp, & - 1,ioutcount,istatus) - j_parent_start=itmp - - do j = jsta_2l, jend_2u - do i = 1, im -! DX ( i, j ) = dxval - DY ( i, j ) = dyval*DTR*ERAD*0.001 - end do - end do - -! generate look up table for lifted parcel calculations - - THL=210. - PLQ=70000. - - CALL TABLE(PTBL,TTBL,PT, & - RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0) - - CALL TABLEQ(TTBLQ,RDPQ,RDTHEQ,PLQ,THL,STHEQ,THE0Q) - -! -! - IF(ME==0)THEN - WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: ' - WRITE(6,51) (SPL(L),L=1,LSM) - 50 FORMAT(14(F4.1,1X)) - 51 FORMAT(8(F8.1,1X)) - ENDIF -! -! COMPUTE DERIVED TIME STEPPING CONSTANTS. -! - call ext_ncd_get_dom_ti_real(DataHandle,'DT',tmp, & - 1,ioutcount,istatus) - DT=tmp - print*,'DT= ',DT - DTQ2 = DT * NPHS - TSPH = 3600./DT - - TSRFC=float(NSRFC)/TSPH - IF(NSRFC==0)TSRFC=float(ifhr) !in case buket does not get emptied - TRDLW=float(NRDLW)/TSPH - IF(NRDLW==0)TRDLW=float(ifhr) !in case buket does not get emptied - TRDSW=float(NRDSW)/TSPH - IF(NRDSW==0)TRDSW=float(ifhr) !in case buket does not get emptied - THEAT=float(NHEAT)/TSPH - IF(NHEAT==0)THEAT=float(ifhr) !in case buket does not get emptied - TCLOD=float(NCLOD)/TSPH - IF(NCLOD==0)TCLOD=float(ifhr) !in case buket does not get emptied - TPREC=float(NPREC)/TSPH - IF(NPREC==0)TPREC=float(ifhr) !in case buket does not get emptied - print*,'TSRFC TRDLW TRDSW= ',TSRFC, TRDLW, TRDSW - -!how am i going to get this information? -! NPREC = INT(TPREC *TSPH+D50) -! NHEAT = INT(THEAT *TSPH+D50) -! NCLOD = INT(TCLOD *TSPH+D50) -! NRDSW = INT(TRDSW *TSPH+D50) -! NRDLW = INT(TRDLW *TSPH+D50) -! NSRFC = INT(TSRFC *TSPH+D50) -!how am i going to get this information? -! -! IF(ME==0)THEN -! WRITE(6,*)' ' -! WRITE(6,*)'DERIVED TIME STEPPING CONSTANTS' -! WRITE(6,*)' NPREC,NHEAT,NSRFC : ',NPREC,NHEAT,NSRFC -! WRITE(6,*)' NCLOD,NRDSW,NRDLW : ',NCLOD,NRDSW,NRDLW -! ENDIF -! -! COMPUTE DERIVED MAP OUTPUT CONSTANTS. - DO L = 1,LSM - ALSL(L) = ALOG(SPL(L)) - END DO -! - if(submodelname == 'NEST') then - print *,'NMM NEST mode: use projection center as projection center' - elseif(submodelname == 'MOAD') then - print *,'NMM MOAD mode: use domain center as projection center' - CENLAT=NINT(DCENLAT*1000) - CENLON=NINT(DCENLON*1000) - elseif(i_parent_start>1 .or. j_parent_start>1) then - print *,'No submodel specified for nested domain. Using projection center as projection center.' - else - print *,'No submodel specified for MOAD. Using domain center as projection center' - endif - - - if(me==0)then - ! write out copygb_gridnav.txt - ! provided by R.Rozumalski - NWS - - inav=10 - - TRUELAT1 = CENLAT - TRUELAT2 = CENLAT - - IFDX = NINT (dxval*107.) - IFDY = NINT (dyval*110.) - - open(inav,file='copygb_gridnav.txt',form='formatted', & - status='unknown') - - print *, ' MAPTYPE :',maptype - print *, ' IM :',IM*2-1 - print *, ' JM :',JM - print *, ' LATSTART :',LATSTART - print *, ' LONSTART :',LONSTART - print *, ' CENLAT :',CENLAT - print *, ' CENLON :',CENLON - print *, ' TRUELAT2 :',TRUELAT2 - print *, ' TRUELAT1 :',TRUELAT1 - print *, ' DX :',IFDX*0.001 - print *, ' DY :',IFDY*0.001 - - IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID - - IMM = 2*IM-1 - IDXAVE = ( IFDY + IFDX ) * 0.5 - - ! If the Center Latitude of the domain is located within 15 degrees - ! of the equator then use a a regular Lat/Lon navigation for the - ! remapped grid in copygb; otherwise, use a Lambert conformal. Make - ! sure to specify the correct pole for the S. Hemisphere (LCC). - ! - IF ( abs(CENLAT)>15000) THEN - write(6,*)' Copygb LCC Navigation Information' - IF (CENLAT >0) THEN ! Northern Hemisphere - write(6,1000) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - write(inav,1000) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - ELSE ! Southern Hemisphere - write(6,1001) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - write(inav,1001) IMM,JM,LATSTART,LONSTART,CENLON, & - IFDX,IFDY,CENLAT,CENLAT - END IF - ELSE - dlat = (latnm-latsm)/(JM-1) - nlat = INT (dlat) - - if (lonem < 0) lonem = 360000. + lonem - if (lonwm < 0) lonwm = 360000. + lonwm - - dlon = lonem-lonwm - if (dlon < 0.) dlon = dlon + 360000. - dlon = (dlon)/(IMM-1) - nlon = INT (dlon) - - write(6,*)' Copygb Lat/Lon Navigation Information' - write(6,2000) IMM,JM,latsm,lonwm,latnm,lonem,nlon,nlat - write(inav,2000) IMM,JM,latsm,lonwm,latnm,lonem,nlon,nlat - ENDIF - close(inav) - - 1000 format('255 3 ',2(I3,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'0 64', & - 2(x,I6)) - 1001 format('255 3 ',2(I3,x),I6,x,I7,x,'8 ',I7,x,2(I6,x),'128 64', & - 2(x,I6),' -90000 0') - 2000 format('255 0 ',2(I3,x),2(I7,x),'8 ',2(I7,x),2(I7,x),'64') - END IF ! maptype - - !HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN - igdout=110 - if (maptype == 1)THEN ! Lambert conformal - WRITE(igdout)3 - WRITE(6,*)'igd(1)=',3 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 -! JW WRITE(igdout)TRUELAT2 -! JW WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ELSE IF(MAPTYPE == 2)THEN !Polar stereographic - WRITE(igdout)5 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)0 - WRITE(igdout)64 -! JW WRITE(igdout)TRUELAT2 !Assume projection at +-90 -! JW WRITE(igdout)TRUELAT1 - WRITE(igdout)255 - ! Note: The calculation of the map scale factor at the standard - ! lat/lon and the PSMAPF - ! Get map factor at 60 degrees (N or S) for PS projection, which will - ! be needed to correctly define the DX and DY values in the GRIB GDS - if (TRUELAT1 < 0.) THEN - LAT = -60. - else - LAT = 60. - end if - - CALL MSFPS (LAT,TRUELAT1*0.001,PSMAPF) - - ELSE IF(MAPTYPE == 3)THEN !Mercator - WRITE(igdout)1 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)8 - WRITE(igdout)latlast - WRITE(igdout)lonlast -! JW WRITE(igdout)TRUELAT1 - WRITE(igdout)0 - WRITE(igdout)64 - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)255 - ELSE IF(MAPTYPE==0 .OR. MAPTYPE==203)THEN !A STAGGERED E-GRID - WRITE(igdout)203 - WRITE(igdout)im - WRITE(igdout)jm - WRITE(igdout)LATSTART - WRITE(igdout)LONSTART - WRITE(igdout)136 - WRITE(igdout)CENLAT - WRITE(igdout)CENLON - WRITE(igdout)DXVAL - WRITE(igdout)DYVAL - WRITE(igdout)64 - WRITE(igdout)0 - WRITE(igdout)0 - WRITE(igdout)0 - -! following for hurricane wrf post - open(inav,file='copygb_hwrf.txt',form='formatted', & - status='unknown') - LATEND=LATSTART+(JM-1)*dyval - LONEND=LONSTART+(IMM-1)*dxval - write(10,1010) IMM,JM,LATSTART,LONSTART,LATEND,LONEND, & - dxval,dyval - -1010 format('255 0 ',2(I3,x),I6,x,I7,x,'136 ',I6,x,I7,x, & - 2(I6,x),'64') - close (inav) - - END IF - end if -! -! -! close up shop - call ext_ncd_ioclose ( DataHandle, Status ) - - RETURN - END diff --git a/sorc/ncep_post.fd/LFMFLD.f b/sorc/ncep_post.fd/LFMFLD.f index a5d83919b..9aeefc635 100644 --- a/sorc/ncep_post.fd/LFMFLD.f +++ b/sorc/ncep_post.fd/LFMFLD.f @@ -1,71 +1,46 @@ !> @file -! . . . -!> SUBPROGRAM: LFMFLD COMPUTES LAYER MEAN LFM FIELDS -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THREE LAYER MEAN RELATIVE HUMIDITIES -!! AND A PRECIPITABLE WATER FIELD FROM ETA LEVEL DATA. THE -!! COMPUTED FIELDS ARE INTENDED TO MIMIC SIMILAR FIELDS COM- -!! PUTED BY THE LFM. THE ALGORITHM USED HERE IS FAIRLY PRI- -!! MATIVE. IN EACH COLUMN ABOVE A MASS POINT ON THE ETA GRID -!! WE SET THE FOLLOWING TARGET PRESSURES: -!! SIGMA LAYER 1.00 PRESSURE: SURFACE PRESSURE -!! SIGMA LAYER 0.66 PRESSURE: 0.50 * SURFACE PRESSURE -!! SIGMA LAYER 0.33 PRESSURE: 0.4356 * SURFACE PRESSURE -!! GIVEN THESE PRESSURES A SURFACE UP SUMMATION IS MADE OF -!! RELATIVE HUMIDITY AND/OR PRECIPITABLE WATER BETWEEN THESE -!! TARGET PRESSURES. EACH TERM IN THE SUMMATION IS WEIGHTED -!! BY THE THICKNESS OF THE ETA LAYER. THE FINAL LAYER MEAN -!! IS THIS SUM NORMALIZED BY THE TOTAL DEPTH OF THE LAYER. -!! THERE IS, OBVIOUSLY, NO NORMALIZATION FOR PRECIPITABLE WATER. -!! -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-07-27 RUSS TREADON - MODIFIED SUMMATION LIMITS FROM -!! 0.66*PSFC TO 0.75*PSFC AND 0.33*PSFC -!! TO 0.50*PSFC, WHERE PSFC IS THE -!! SURFACES PRESSURE. THE REASON FOR -!! THIS CHANGE WAS RECOGNITION THAT IN -!! THE LFM 0.33 AND 0.66 WERE MEASURED -!! FROM THE SURFACE TO THE TROPOPAUSE, -!! NOT THE TOP OF THE MODEL. -!! 93-09-13 RUSS TREADON - RH CALCULATIONS WERE MADE INTERNAL -!! TO THE ROUTINE. -!! 96-03-04 MIKE BALDWIN - CHANGE PW CALC TO INCLUDE CLD WTR -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-08-17 MIKE BALDWIN - COMPUTE RH OVER ICE -!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! -!! -!! USAGE: CALL LFMFLD(RH3310,RH6610,RH3366,PW3310) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! RH3310 - SIGMA LAYER 0.33-1.00 MEAN RELATIVE HUMIDITY. -!! RH6610 - SIGMA LAYER 0.66-1.00 MEAN RELATIVE HUMIDITY. -!! RH3366 - SIGMA LAYER 0.33-0.66 MEAN RELATIVE HUMIDITY. -!! PW3310 - SIGMA LAYER 0.33-1.00 PRECIPITABLE WATER. -!! -!! OUTPUT FILES: -!! NONE -!! -!! LIBRARY: -!! COMMON - -!! MAPOT -!! LOOPS -!! OPTIONS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief lfmfld() computes layer mean LFM fields. +!> +!> This routine computes three layer mean relative humidities +!> and a precipitable water field from ETA level data. The +!> computed fields are intended to mimic similar fields com- +!> puted by the LFM. The algorithm used here is fairly pri- +!> mative. +!> 
+!> In each column above a mass point on the ETA grid we set the following target pressures:
+!>     Sigma layer 1.00 pressure:  Surface pressure
+!>     Sigma layer 0.66 pressure:  0.50 * Surface pressure
+!>     Sigma layer 0.33 pressure:  0.4356 * Surface pressure
+!>
+!> Given there pressures a surface up summation is made of +!> relative humidity and/or precipitable water between these +!> target pressures. Each term in the summation is weighted +!> By the thickness of the ETA layer. The final layer mean +!> is this sum normalized by the total depth of the layer. +!> There is, obviously, no normalization for precipitable water. +!> +!> @param[out] RH3310 Sigma layer 0.33-1.00 mean relative humidity. +!> @param[out] RH6610 Sigma layer 0.66-1.00 mean relative humidity. +!> @param[out] RH3366 Sigma layer 0.33-0.66 mean relative humidity. +!> @param[out] PW3310 Sigma layer 0.33-1.00 precipitable water. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-07-27 | Russ Treadon | Modified summation limits from 0.66*PSFC to 0.75*PSFC and 0.33*PSFC to 0.50*PSFC, where PSFC is the surfaces pressure. The reason for this change was recognition that in the LFM 0.33 and 0.66 were measured from the surface to the tropopause not the top of the model. +!> 1993-09-13 | Russ Treadon | RH calculations were made internal to the routine. +!> 1996-03-04 | Mike Baldwin | Change PW CALC to include CLD WTR +!> 1998-06-16 | T Black | Conversion from 1-D to 2-D +!> 1998-08-17 | Mike Baldwin | Compute RH over ice +!> 1998-12-22 | Mike Baldwin | Back out RH over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2019-10-30 | Bo Cui | Remove "GOTO" statement +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-10-14 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) ! @@ -73,7 +48,7 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) use vrbls3d, only: pint, alpint, zint, t, q, cwm use masks, only: lmh use params_mod, only: d00, d50, pq0, a2, a3, a4, h1, d01, gi - use ctlblk_mod, only: jsta, jend, modelname, spval, im + use ctlblk_mod, only: jsta, jend, modelname, spval, im, ista, iend use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1 use upp_physics, only: FPVSNEW @@ -86,8 +61,8 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) ! DECLARE VARIABLES. ! REAL ALPM, DZ, ES, PM, PWSUM, QM, QS, TM, DP, RH - REAL,dimension(IM,jsta:jend),intent(inout) :: RH3310, RH6610, RH3366 - REAL,dimension(IM,jsta:jend),intent(inout) :: PW3310 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: RH3310, RH6610, RH3366 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: PW3310 real Z3310,Z6610,Z3366,P10,P33,P66 integer I,J,L,LLMH ! @@ -98,7 +73,7 @@ SUBROUTINE LFMFLD(RH3310,RH6610,RH3366,PW3310) ! LOOP OVER HORIZONTAL GRID. ! DO 30 J=JSTA,JEND - DO 30 I=1,IM + DO 30 I=ISTA,IEND ! ! ZERO VARIABLES. RH3310(I,J) = D00 diff --git a/sorc/ncep_post.fd/LFMFLD_GFS.f b/sorc/ncep_post.fd/LFMFLD_GFS.f index e89436e39..70ee6e438 100644 --- a/sorc/ncep_post.fd/LFMFLD_GFS.f +++ b/sorc/ncep_post.fd/LFMFLD_GFS.f @@ -1,74 +1,47 @@ !> @file -! . . . -!> SUBPROGRAM: LFMFLD COMPUTES LAYER MEAN LFM FIELDS -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THREE LAYER MEAN RELATIVE HUMIDITIES -!! AND A PRECIPITABLE WATER FIELD FROM ETA LEVEL DATA. THE -!! COMPUTED FIELDS ARE INTENDED TO MIMIC SIMILAR FIELDS COM- -!! PUTED BY THE LFM. THE ALGORITHM USED HERE IS FAIRLY PRI- -!! MATIVE. IN EACH COLUMN ABOVE A MASS POINT ON THE ETA GRID -!! WE SET THE FOLLOWING TARGET PRESSURES: -!! SIGMA LAYER 1.00 PRESSURE: SURFACE PRESSURE -!! SIGMA LAYER 0.66 PRESSURE: 0.50 * SURFACE PRESSURE -!! SIGMA LAYER 0.33 PRESSURE: 0.4356 * SURFACE PRESSURE -!! GIVEN THESE PRESSURES A SURFACE UP SUMMATION IS MADE OF -!! RELATIVE HUMIDITY AND/OR PRECIPITABLE WATER BETWEEN THESE -!! TARGET PRESSURES. EACH TERM IN THE SUMMATION IS WEIGHTED -!! BY THE THICKNESS OF THE ETA LAYER. THE FINAL LAYER MEAN -!! IS THIS SUM NORMALIZED BY THE TOTAL DEPTH OF THE LAYER. -!! THERE IS, OBVIOUSLY, NO NORMALIZATION FOR PRECIPITABLE WATER. -!! -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-07-27 RUSS TREADON - MODIFIED SUMMATION LIMITS FROM -!! 0.66*PSFC TO 0.75*PSFC AND 0.33*PSFC -!! TO 0.50*PSFC, WHERE PSFC IS THE -!! SURFACES PRESSURE. THE REASON FOR -!! THIS CHANGE WAS RECOGNITION THAT IN -!! THE LFM 0.33 AND 0.66 WERE MEASURED -!! FROM THE SURFACE TO THE TROPOPAUSE, -!! NOT THE TOP OF THE MODEL. -!! 93-09-13 RUSS TREADON - RH CALCULATIONS WERE MADE INTERNAL -!! TO THE ROUTINE. -!! 96-03-04 MIKE BALDWIN - CHANGE PW CALC TO INCLUDE CLD WTR -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-08-17 MIKE BALDWIN - COMPUTE RH OVER ICE -!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! 06-11-06 H CHUANG - MODIFY TO OUTPUT GFS LFM FIELDS WHICH -!! HAVE DIFFERENT THICKNESS AS MESO AND USE DP -!! RATHER THAN DZ -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! -!! -!! USAGE: CALL LFMFLD(RH3310,RH6610,RH3366,PW3310) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! RH3310 - SIGMA LAYER 0.33-1.00 MEAN RELATIVE HUMIDITY. -!! RH6610 - SIGMA LAYER 0.66-1.00 MEAN RELATIVE HUMIDITY. -!! RH3366 - SIGMA LAYER 0.33-0.66 MEAN RELATIVE HUMIDITY. -!! PW3310 - SIGMA LAYER 0.33-1.00 PRECIPITABLE WATER. -!! -!! OUTPUT FILES: -!! NONE -!! -!! LIBRARY: -!! COMMON - -!! MAPOT -!! LOOPS -!! OPTIONS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief lfmfld_gfs() computes layer mean LFM fields. +!> +!> This routine computes three layer mean relative humidities +!> and a precipitable water field from ETA level data. The +!> computed fields are intended to mimic similar fields com- +!> puted by the LFM. The algorithm used here is fairly pri- +!> mative. +!> 
+!> In each column above a mass point on the ETA grid we set the following target pressures:
+!>     Sigma layer 1.00 pressure:  Surface pressure
+!>     Sigma layer 0.66 pressure:  0.50 * Surface pressure
+!>     Sigma layer 0.33 pressure:  0.4356 * Surface pressure
+!>
+!> Given there pressures a surface up summation is made of +!> relative humidity and/or precipitable water between these +!> target pressures. Each term in the summation is weighted +!> By the thickness of the ETA layer. The final layer mean +!> is this sum normalized by the total depth of the layer. +!> There is, obviously, no normalization for precipitable water. +!> +!> @param[out] RH3310 Sigma layer 0.33-1.00 mean relative humidity. +!> @param[out] RH6610 Sigma layer 0.66-1.00 mean relative humidity. +!> @param[out] RH3366 Sigma layer 0.33-0.66 mean relative humidity. +!> @param[out] PW3310 Sigma layer 0.33-1.00 precipitable water. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-07-27 | Russ Treadon | Modified summation limits from 0.66*PSFC to 0.75*PSFC and 0.33*PSFC to 0.50*PSFC, where PSFC is the surfaces pressure. The reason for this change was recognition that in the LFM 0.33 and 0.66 were measured from the surface to the tropopause not the top of the model. +!> 1993-09-13 | Russ Treadon | RH calculations were made internal to the routine. +!> 1996-03-04 | Mike Baldwin | Change PW CALC to include CLD WTR +!> 1998-06-16 | T Black | Conversion from 1-D to 2-D +!> 1998-08-17 | Mike Baldwin | Compute RH over ice +!> 1998-12-22 | Mike Baldwin | Back out RH over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2006-11-06 | H CHUANG | Modify to output GFS LFM fields which have different thickness as MESO and use DP rather than DZ +!> 2019-10-30 | Bo Cui | Remove "GOTO" statement +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-10-14 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) ! @@ -76,7 +49,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) use vrbls3d, only: pint, q, t, pmid use masks, only: lmh use params_mod, only: d00 - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: jsta, jend, spval, im, ista, iend use upp_physics, only: FPVSNEW ! implicit none @@ -92,7 +65,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) ! DECLARE VARIABLES. ! REAL ALPM, DZ, ES, PM, PWSUM, QM, QS - REAL,dimension(IM,jsta:jend),intent(out) :: RH4410, RH7294, RH4472 & + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH4410, RH7294, RH4472 & ,RH3310 ! integer I,J,L,LLMH @@ -106,7 +79,7 @@ SUBROUTINE LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) ! LOOP OVER HORIZONTAL GRID. ! DO 30 J=JSTA,JEND - DO 30 I=1,IM + DO 30 I=ISTA,IEND ! ! ZERO VARIABLES. RH4410(I,J) = D00 diff --git a/sorc/ncep_post.fd/MAPSSLP.f b/sorc/ncep_post.fd/MAPSSLP.f index 6eda2b217..6666631cd 100644 --- a/sorc/ncep_post.fd/MAPSSLP.f +++ b/sorc/ncep_post.fd/MAPSSLP.f @@ -10,7 +10,8 @@ SUBROUTINE MAPSSLP(TPRES) ! !----------------------------------------------------------------------- use ctlblk_mod, only: jsta, jend, spl, smflag, lm, im, jsta_2l, jend_2u, & - lsm, jm, grib, spval + lsm, jm, grib, spval, & + ista, iend, ista_2l, iend_2u use gridspec_mod, only: maptype, dxval use vrbls3d, only: pmid, t, pint use vrbls2d, only: pslp, fis @@ -21,11 +22,11 @@ SUBROUTINE MAPSSLP(TPRES) ! INCLUDE "mpif.h" ! - REAL TPRES(IM,JSTA_2L:JEND_2U,LSM) + REAL TPRES(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM) real LAPSES, EXPo,EXPINV,TSFCNEW - REAL,dimension(im, jsta_2l:jend_2u) :: T700 + REAL,dimension(ista_2l:iend_2u, jsta_2l:jend_2u) :: T700 real,dimension(im,2) :: sdummy REAL,dimension(im,jm) :: GRID1, TH700 INTEGER NSMOOTH @@ -42,7 +43,7 @@ SUBROUTINE MAPSSLP(TPRES) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(SPL(L) == 70000.)THEN if(TPRES(I,J,L) 100.) THEN @@ -112,7 +113,7 @@ SUBROUTINE MAPSSLP(TPRES) CALL SMOOTH(GRID1,SDUMMY,IM,JM,0.5) end do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PSLP(I,J)=GRID1(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/MDL2AGL.f b/sorc/ncep_post.fd/MDL2AGL.f index b1f5254fa..55d97b07c 100644 --- a/sorc/ncep_post.fd/MDL2AGL.f +++ b/sorc/ncep_post.fd/MDL2AGL.f @@ -16,6 +16,7 @@ !! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! 21-04-01 J MENG - computation on defined points only !! 21-07-26 W Meng - Restrict computation from undefined grids +!! 21-10-14 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -61,7 +62,8 @@ SUBROUTINE MDL2AGL use params_mod, only: dbzmin, small, eps, rd use ctlblk_mod, only: spval, lm, modelname, grib, cfld, fld_info, datapd,& ifhr, global, jsta_m, jend_m, mpi_comm_comp, & - jsta_2l, jend_2u, im, jm, jsta, jend, imp_physics + jsta_2l, jend_2u, im, jm, jsta, jend, imp_physics, & + ista, iend, ista_2l, iend_2u, ista_m, iend_m use rqstfld_mod, only: iget, lvls, iavblfld, lvlsxml, id use gridspec_mod, only: gridtype !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -77,10 +79,10 @@ SUBROUTINE MDL2AGL ! DECLARE VARIABLES. ! LOGICAL IOOMG,IOALL - REAL,dimension(im,jsta_2l:jend_2u) :: grid1 - REAL,dimension(im,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1 + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: UAGL, VAGL, tagl, pagl, qagl ! - INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X integer,dimension(jm) :: IHE, IHW INTEGER LXXX,IERR, maxll, minll INTEGER ISTART,ISTOP,JSTART,JSTOP @@ -100,7 +102,7 @@ SUBROUTINE MDL2AGL ! ! REAL C1D(IM,JM),QW1(IM,JM),QI1(IM,JM),QR1(IM,JM) ! &, QS1(IM,JM) ,DBZ1(IM,JM) - REAL,dimension(im,jsta:jend) :: DBZ1, DBZR1, DBZI1, DBZC1, dbz1log + REAL,dimension(ista:iend,jsta:jend) :: DBZ1, DBZR1, DBZI1, DBZC1, dbz1log real,dimension(lagl) :: ZAGL real,dimension(lagl2) :: ZAGL2, ZAGL3 real PAGLU,PAGLL,TAGLU,TAGLL,QAGLU,QAGLL, pv, rho @@ -149,10 +151,10 @@ SUBROUTINE MDL2AGL IF (iget1 > 0 .or. iget2 > 0 .or. iget3 > 0 .or. iget4 > 0) then ! jj=float(jsta+jend)/2.0 - ii=float(im)/3.0 + ii=float(ista+iend)/3.0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DBZ1(I,J) = SPVAL DBZR1(I,J) = SPVAL DBZI1(I,J) = SPVAL @@ -195,7 +197,7 @@ SUBROUTINE MDL2AGL ! DO 220 J=JSTA,JEND DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -281,13 +283,13 @@ SUBROUTINE MDL2AGL IF((IGET(253)>0) )THEN if(MODELNAME=='RAPR') then DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=DBZ1LOG(I,J) ENDDO ENDDO else DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=DBZ1(I,J) ENDDO ENDDO @@ -296,13 +298,13 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(253)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(253)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Radar reflectivity from rain IF((IGET(279)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=DBZR1(I,J) ENDDO ENDDO @@ -310,13 +312,13 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(279)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(279)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Radar reflectivity from all ice habits (snow + graupel + sleet, etc.) IF((IGET(280)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=DBZI1(I,J) ENDDO ENDDO @@ -324,13 +326,13 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(280)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(280)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Radar reflectivity from parameterized convection IF((IGET(281)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=DBZC1(I,J) ENDDO ENDDO @@ -338,7 +340,7 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(281)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(281)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF ! @@ -355,7 +357,7 @@ SUBROUTINE MDL2AGL !--- Max Derived Radar Reflectivity IF((IGET(421)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=REFD_MAX(I,J) ENDDO ENDDO @@ -370,14 +372,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat=0 endif fld_info(cfld)%ntrange=1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Max Derived Radar Reflectivity at -10C IF((IGET(785)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=REFDM10C_MAX(I,J) ENDDO ENDDO @@ -391,14 +393,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat=0 endif fld_info(cfld)%ntrange=1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Max Updraft Helicity IF((IGET(420)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MAX(I,J) ENDDO ENDDO @@ -412,14 +414,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Updraft Helicity 1-6 km IF((IGET(700)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MAX16(I,J) ENDDO ENDDO @@ -433,14 +435,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Min Updraft Helicity IF((IGET(786)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MIN(I,J) ENDDO ENDDO @@ -454,14 +456,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Min Updraft Helicity 1-6 km IF((IGET(787)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MIN16(I,J) ENDDO ENDDO @@ -475,14 +477,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Updraft Helicity 0-2 km IF((IGET(788)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MAX02(I,J) ENDDO ENDDO @@ -496,13 +498,13 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Min Updraft Helicity 0-2 km IF((IGET(789)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MIN02(I,J) ENDDO ENDDO @@ -516,14 +518,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Updraft Helicity 0-3 km IF((IGET(790)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MAX03(I,J) ENDDO ENDDO @@ -537,14 +539,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Min Updraft Helicity 0-3 km IF((IGET(791)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI_MIN03(I,J) ENDDO ENDDO @@ -558,14 +560,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Relative Vertical Vorticity 0-2 km IF((IGET(792)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=REL_VORT_MAX(I,J) ENDDO ENDDO @@ -579,14 +581,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Relative Vertical Vorticity 0-1 km IF((IGET(793)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=REL_VORT_MAX01(I,J) ENDDO ENDDO @@ -600,13 +602,13 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Relative Vertical Vorticity @ hybrid level 1 IF((IGET(890)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=REL_VORT_MAXHY1(I,J) ENDDO ENDDO @@ -620,14 +622,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 0 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Hail Diameter in Column IF((IGET(794)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=HAIL_MAX2D(I,J) ENDDO ENDDO @@ -641,14 +643,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Hail Diameter at k=1 IF((IGET(795)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=HAIL_MAXK1(I,J) ENDDO ENDDO @@ -662,7 +664,7 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF @@ -671,7 +673,7 @@ SUBROUTINE MDL2AGL ! (J. Kenyon/GSD, added 1 May 2019) IF((IGET(728)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=HAIL_MAXHAILCAST(I,J)/1000.0 ! convert mm to m ENDDO ENDDO @@ -685,14 +687,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Column Integrated Graupel IF((IGET(429)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=GRPL_MAX(I,J) ENDDO ENDDO @@ -706,14 +708,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Lightning Threat 1 IF((IGET(702)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=LTG1_MAX(I,J) ENDDO ENDDO @@ -727,14 +729,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Lightning Threat 2 IF((IGET(703)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=LTG2_MAX(I,J) ENDDO ENDDO @@ -748,14 +750,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif END IF !--- Max Lightning Threat 3 IF((IGET(704)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=LTG3_MAX(I,J) ENDDO ENDDO @@ -769,14 +771,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- GSD Updraft Helicity IF((IGET(727)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI(I,J) ENDDO ENDDO @@ -784,14 +786,14 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(727)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(727)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Updraft Helicity 1-6 km layer IF((IGET(701)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UP_HELI16(I,J) ENDDO ENDDO @@ -799,14 +801,14 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(701)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(701)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Convective Initiation Lightning IF((IGET(705)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=NCI_LTG(I,J)/60.0 ENDDO ENDDO @@ -820,14 +822,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Convective Activity Lightning IF((IGET(706)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=NCA_LTG(I,J)/60.0 ENDDO ENDDO @@ -841,14 +843,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Convective Initiation Vertical Hydrometeor Flux IF((IGET(707)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=NCI_WQ(I,J)/60.0 ENDDO ENDDO @@ -862,14 +864,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Convective Activity Vertical Hydrometeor Flux IF((IGET(708)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=NCA_WQ(I,J)/60.0 ENDDO ENDDO @@ -883,14 +885,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Convective Initiation Reflectivity IF((IGET(709)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=NCI_REFD(I,J)/60.0 ENDDO ENDDO @@ -904,14 +906,14 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF !--- Convective Activity Reflectivity IF((IGET(710)>0) )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=NCA_REFD(I,J)/60.0 ENDDO ENDDO @@ -925,7 +927,7 @@ SUBROUTINE MDL2AGL fld_info(cfld)%tinvstat = 1 endif fld_info(cfld)%ntrange = 1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF ! @@ -949,9 +951,9 @@ SUBROUTINE MDL2AGL IF(iget1 > 0 .or. iget2 > 0) THEN ! jj=(jsta+jend)/2 - ii=(im)/2 + ii=(ista+iend)/2 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND UAGL(I,J) = SPVAL VAGL(I,J) = SPVAL ! @@ -1000,13 +1002,13 @@ SUBROUTINE MDL2AGL END IF ENDDO IF(global)then - ISTART=1 - ISTOP=IM + ISTART=ISTA + ISTOP=IEND JSTART=JSTA JSTOP=JEND ELSE - ISTART=2 - ISTOP=IM-1 + ISTART=ISTA_M + ISTOP=IEND_M JSTART=JSTA_M JSTOP=JEND_M END IF @@ -1018,8 +1020,8 @@ SUBROUTINE MDL2AGL MINLL=LXXX ! print*,'exchange wind in MDL2AGL from ',MINLL DO LL=MINLL,LM - call exch(UH(1:IM,JSTA_2L:JEND_2U,LL)) - call exch(VH(1:IM,JSTA_2L:JEND_2U,LL)) + call exch(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LL)) + call exch(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LL)) END DO END IF DO 230 J=JSTART,JSTOP @@ -1128,7 +1130,7 @@ SUBROUTINE MDL2AGL !--- Wind Shear (wind speed difference in knots between sfc and 2000 ft) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(UAGL(I,J)-SPVAL)>SMALL .AND. & ABS(VAGL(I,J)-SPVAL)>SMALL)THEN IF(GRIDTYPE=='B' .OR. GRIDTYPE=='E')THEN @@ -1149,7 +1151,7 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(259)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(259)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ! ENDIF ! FOR LEVEL @@ -1178,9 +1180,9 @@ SUBROUTINE MDL2AGL ! jj = float(jsta+jend)/2.0 - ii = float(im)/3.0 + ii = float(ista+iend)/3.0 DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U ! PAGL(I,J) = SPVAL TAGL(I,J) = SPVAL @@ -1224,7 +1226,7 @@ SUBROUTINE MDL2AGL !chc J=JHOLD(NN) ! DO 220 J=JSTA,JEND DO 240 J=JSTA_2L,JEND_2U - DO 240 I=1,IM + DO 240 I=ISTA_2L,IEND_2U LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -1295,7 +1297,7 @@ SUBROUTINE MDL2AGL !--- Wind Energy Potential -- 0.5 * moist air density * wind speed^3 IF((IGET(411)>0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(QAGL(I,J)0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=UAGL(I,J) ENDDO ENDDO @@ -1325,13 +1327,13 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(412)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(412)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- V Component of wind IF((IGET(413)>0) ) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=VAGL(I,J) ENDDO ENDDO @@ -1339,7 +1341,7 @@ SUBROUTINE MDL2AGL cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(413)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(413)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! diff --git a/sorc/ncep_post.fd/MDL2P.f b/sorc/ncep_post.fd/MDL2P.f index 1b435cd5a..8a023af0e 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -1,64 +1,37 @@ !> @file -! . . . -!> SUBPROGRAM: MDL2P VERT INTRP OF MODEL LVLS TO PRESSURE -!! PRGRMMR: BLACK ORG: W/NP22 DATE: 99-09-23 -!! -!! ABSTRACT: -!! FOR MOST APPLICATIONS THIS ROUTINE IS THE WORKHORSE OF THE POST PROCESSOR. -!! IN A NUTSHELL IT INTERPOLATES DATA FROM MODEL TO PRESSURE SURFACES. -!! IT ORIGINATED FROM THE VERTICAL INTERPOLATION CODE IN THE OLD ETA -!! POST PROCESSOR SUBROUTINE OUTMAP AND IS A REVISION OF SUBROUTINE ETA2P. -!! -!! PROGRAM HISTORY LOG: -!! 99-09-23 T BLACK - REWRITTEN FROM ETA2P -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-12 MIKE BALDWIN - WRF VERSION -!! 02-07-29 H CHUANG - ADD UNDERGROUND FIELDS AND MEMBRANE SLP FOR WRF -!! 04-11-24 H CHUANG - ADD FERRIER'S HYDROMETEOR FIELD -!! 05-07-07 B ZHOU - ADD RSM MODEL for SLP -!! 05--8-30 B ZHOU - ADD AVIATION PRODUCTS: ICING, CAT, LLWS COMPUTATION -!! 08-01-01 H CHUANG - ADD GFS D3D FIELDS TO VERTICAL INTERPOLATION -!! 10-07-01 SMIRNOVA AND HU - ADD RR CHANGES -!! 10-12-30 H CHUANG - ADD HAINES INDEX TO SUPPORT FIRE WEATHER -!! 11-02-06 J Wang - ADD grib2 option TO SUPPORT FIRE WEATHER -!! 12-01-11 S LU - ADD GOCART AEROSOLS -!! 13-08-01 S Moorthi - some optimization -!! 14-02-26 S Moorthi - threading datapd assignment -!! 19-10-30 B CUI - REMOVE "GOTO" STATEMENT -!! 20-03-25 J MENG - remove grib1 -!! 20-05-20 J MENG - CALRH unification with NAM scheme -!! 20-11-10 J MENG - USE UPP_PHYSICS MODULE -!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) -!! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY -!! -!! USAGE: CALL MDL2P -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! SCLFLD - SCALE ARRAY ELEMENTS BY CONSTANT. -!! CALPOT - COMPUTE POTENTIAL TEMPERATURE. -!! CALRH - COMPUTE RELATIVE HUMIDITY. -!! CALDWP - COMPUTE DEWPOINT TEMPERATURE. -!! BOUND - BOUND ARRAY ELEMENTS BETWEEN LOWER AND UPPER LIMITS. -!! CALMCVG - COMPUTE MOISTURE CONVERGENCE. -!! CALVOR - COMPUTE ABSOLUTE VORTICITY. -!! CALSTRM - COMPUTE GEOSTROPHIC STREAMFUNCTION. -!! -!! LIBRARY: -!! COMMON - CTLBLK -!! RQSTFLD -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief mdl2p() computes vert intrp of model lvls to pressure. +!> +!> For most applications this routine is the workhorse of the post processor. +!> In a nutshell it interpolates data from model to pressure surfaces. +!> It origiaated from the vertical interpolation code in the old ETA +!> post processor subroutine outmap() and is a revision of subroutine eta2p(). +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1999-09-23 | T Black | Rewritten from eta2p() +!> 2001-10-25 | H Chuang | Modified to process hybrid model output +!> 2002-06-12 | Mike Baldwin | WRF Version +!> 2002-07-29 | H Chuang | Add underground fields and membrane SLP for WRF +!> 2004-11-24 | H Chuang | Add FERRIER's hydrometeor field +!> 2005-07-07 | B Zhou | Add RSM model for SLP +!> 2005--8-30 | B Zhou | Add aviation products: ICING, CAT, LLWS computation +!> 2008-01-01 | H Chuang | Add GFS D3D fields to vertical interpolation +!> 2010-07-01 | Smirnova and Hu | Add RR changes +!> 2010-12-30 | H Chuang | Add Haines index to support fire weather +!> 2011-02-06 | J Wang | Add grib2 option to support fire weather +!> 2012-01-11 | S Lu | Add GOCART aerosols +!> 2013-08-01 | S Moorthi | Some optimization +!> 2014-02-26 | S Moorthi | Threading datapd assignment +!> 2019-10-30 | B Cui | Remove "GOTO" statement +!> 2020-03-25 | J Meng | Remove grib1 +!> 2020-05-20 | J Meng | CALRH unification with NAM scheme +!> 2020-11-10 | J Meng | Use UPP_PHYSICS module +!> 2021-03-11 | B Cui | Change local arrays to dimension (im,jsta:jend) +!> 2021-04-01 | J Meng | Computation on defined points only +!> 2021-07-07 | J MENG | 2D DECOMPOSITION +!> +!> @author T Black W/NP2 @date 1999-09-23 SUBROUTINE MDL2P(iostatusD3D) ! @@ -84,10 +57,10 @@ SUBROUTINE MDL2P(iostatusD3D) ALSL, JEND_M, SMFLAG, GRIB, CFLD, FLD_INFO, DATAPD,& TD3D, IFHR, IFMIN, IM, JM, NBIN_DU, JSTA_2L, & JEND_2U, LSM, d3d_on, gocart_on, ioform, NBIN_SM, & - imp_physics + imp_physics, ISTA, IEND, ISTA_M, IEND_M, ISTA_2L, IEND_2U use rqstfld_mod, only: IGET, LVLS, ID, IAVBLFLD, LVLSXML use gridspec_mod, only: GRIDTYPE, MAPTYPE, DXVAL - use upp_physics, only: FPVSNEW, CALRH + use upp_physics, only: FPVSNEW, CALRH, CALVOR !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! implicit none @@ -104,7 +77,7 @@ SUBROUTINE MDL2P(iostatusD3D) real,PARAMETER :: CAPA=0.28589641,P1000=1000.E2 LOGICAL IOOMG,IOALL real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(im,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: FSL, TSL, QSL, OSL, USL, VSL & &, Q2SL, WSL, CFRSL, O3SL, TDSL & &, EGRID1, EGRID2 & &, FSL_OLD, USL_OLD, VSL_OLD & @@ -113,8 +86,8 @@ SUBROUTINE MDL2P(iostatusD3D) REAL, allocatable :: D3DSL(:,:,:), DUSTSL(:,:,:), SMOKESL(:,:,:) ! integer,intent(in) :: iostatusD3D - INTEGER, dimension(im,jsta_2l:jend_2u) :: NL1X, NL1XF - real, dimension(IM,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS + INTEGER, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X, NL1XF + real, dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM) :: TPRS, QPRS, FPRS ! INTEGER K, NSMOOTH ! @@ -128,15 +101,15 @@ SUBROUTINE MDL2P(iostatusD3D) ! QG1 - graupel mixing ratio ! DBZ1 - radar reflectivity ! - REAL, dimension(im,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, DBZ1 & + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: C1D, QW1, QI1, QR1, QS1, QG1, DBZ1 & , FRIME, RAD, HAINES REAL SDUMMY(IM,2) ! SAVE RH, U,V, for Icing, CAT, LLWS computation - REAL SAVRH(IM,jsta:jend) + REAL SAVRH(ista:iend,jsta:jend) !jw - integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,ista,imois,luhi,la + integer I,J,L,LP,LL,LLMH,JJB,JJE,II,JJ,LI,IFINCR,ITD3D,istaa,imois,luhi,la real fact,ALPSL,PSFC,QBLO,PNL1,TBLO,TVRL,TVRBLO,FAC,PSLPIJ, & ALPTH,AHF,PDV,QL,TVU,TVD,GAMMAS,QSAT,RHL,ZL,TL,PL,ES,part,dum1 logical log1 @@ -146,6 +119,8 @@ SUBROUTINE MDL2P(iostatusD3D) ! ! START MDL2P. ! + if(me==0) print*, 'MDL2P SMFLAG=',SMFLAG + if (modelname == 'GFS') then zero = 0.0 else @@ -239,7 +214,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print*,'LSM= ',lsm if(gridtype == 'B' .or. gridtype == 'E') & - call exch(PINT(1:IM,JSTA_2L:JEND_2U,LP1)) + call exch(PINT(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LP1)) DO LP=1,LSM @@ -251,7 +226,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j,l) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U TSL(I,J) = SPVAL QSL(I,J) = SPVAL FSL(I,J) = SPVAL @@ -312,12 +287,12 @@ SUBROUTINE MDL2P(iostatusD3D) !hc J=JHOLD(NN) ! DO 220 J=JSTA,JEND - ii = im/2 + ii = (ista+iend)/2 jj = (jsta+jend)/2 !$omp parallel do private(i,j,k,l,ll,llmh,la,tvd,tvu,fact,fac,ahf,rhl,tl,pl,ql,zl,es,qsat,part,tvrl,tvrblo,tblo,qblo,gammas,pnl1) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC !*** HUMIDITY, CLOUD WATER/ICE, OMEGA, WINDS, AND TKE. @@ -785,7 +760,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TPRS(I,J,LP) = TSL(I,J) QPRS(I,J,LP) = QSL(I,J) FPRS(I,J,LP) = FSL(I,J) @@ -796,7 +771,8 @@ SUBROUTINE MDL2P(iostatusD3D) ! IF(gridtype == 'E')THEN DO J=JSTA,JEND - DO I=2,IM-MOD(J,2) +! DO I=2,IM-MOD(J,2) + DO I=ISTA_M,IEND-MOD(J,2) ! IF(i == im/2 .and. j == (jsta+jend)/2)then ! do l=1,lm ! print*,'PMIDV=',PMIDV(i,j,l) @@ -846,13 +822,13 @@ SUBROUTINE MDL2P(iostatusD3D) ! ! IF(NL1X(I,J) == LMP1.AND.PINT(I,J,LMP1) > SPL(LP))THEN IF(NL1X(I,J) == LP1)THEN - IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC + IF(J == JSTA .AND. I < IEND)THEN !SOUTHERN BC PDV = 0.5*(PINT(I,J,LP1)+PINT(I+1,J,LP1)) - ELSE IF(J == JM .AND. I < IM)THEN !NORTHERN BC + ELSE IF(J == JEND .AND. I < IEND)THEN !NORTHERN BC PDV = 0.5*(PINT(I,J,LP1)+PINT(I+1,J,LP1)) - ELSE IF(I == 1 .AND. MOD(J,2) == 0) THEN !WESTERN EVEN BC + ELSE IF(I == ISTA .AND. MOD(J,2) == 0) THEN !WESTERN EVEN BC PDV = 0.5*(PINT(I,J-1,LP1)+PINT(I,J+1,LP1)) - ELSE IF(I == IM .AND. MOD(J,2) == 0) THEN !EASTERN EVEN BC + ELSE IF(I == IEND .AND. MOD(J,2) == 0) THEN !EASTERN EVEN BC PDV = 0.5*(PINT(I,J-1,LP1)+PINT(I,J+1,LP1)) ELSE IF (MOD(J,2) < 1) THEN PDV = 0.25*(PINT(I,J,LP1)+PINT(I-1,J,LP1) & @@ -870,8 +846,8 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND - DO I=1,IM-MOD(j,2) - +! DO I=1,IM-MOD(j,2) + DO I=ISTA,IEND-MOD(j,2) LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID @@ -920,12 +896,13 @@ SUBROUTINE MDL2P(iostatusD3D) JJE = JEND IF(MOD(JEND,2) == 0) JJE = JEND-1 DO J=JJB,JJE,2 !chc - USL(IM,J) = USL(IM-1,J) - VSL(IM,J) = VSL(IM-1,J) + USL(IEND,J) = USL(IEND-1,J) + VSL(IEND,J) = VSL(IEND-1,J) END DO ELSE IF(gridtype=='B')THEN ! B grid wind interpolation DO J=JSTA,JEND_m - DO I=1,IM-1 +! DO I=1,IM-1 + DO I=ISTA,IEND_m !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! @@ -955,8 +932,8 @@ SUBROUTINE MDL2P(iostatusD3D) ENDDO ! DO J=JSTA,JEND_m - DO I=1,IM-1 - +! DO I=1,IM-1 + DO I=ISTA,IEND_m LL = NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF WINDS FOR A-E GRID @@ -1013,7 +990,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(NINT(SPL(LP)) == 50000)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND T500(I,J) = TSL(I,J) Z500(I,J) = FSL(I,J)*GI ENDDO @@ -1026,7 +1003,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(NINT(SPL(LP)) == 70000)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND T700(I,J) = TSL(I,J) Z700(I,J) = FSL(I,J)*GI ENDDO @@ -1098,7 +1075,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J) < SPVAL) THEN GRID1(I,J) = FSL(I,J)*GI ELSE @@ -1130,11 +1107,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(012)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(012)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1149,7 +1127,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(013)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TSL(I,J) ENDDO ENDDO @@ -1166,11 +1144,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(013)) fld_info(cfld)%lvl = LVLSXML(LP,IGET(013)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1183,7 +1162,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(910))>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TSL(I,J) < SPVAL .AND. QSL(I,J) < SPVAL) THEN GRID1(I,J) = TSL(I,J)*(1.+0.608*QSL(I,J)) ELSE @@ -1204,11 +1183,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld=cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(910)) fld_info(cfld)%lvl = LVLSXML(LP,IGET(910)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1224,7 +1204,7 @@ SUBROUTINE MDL2P(iostatusD3D) tem = (P1000/spl(lp)) ** capa !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TSL(I,J) < SPVAL) THEN grid1(I,J) = TSL(I,J) * tem ELSE @@ -1251,11 +1231,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(014)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(014)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1278,16 +1259,16 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(I,J) = SPL(LP) ENDDO ENDDO ! - CALL CALRH(EGRID2(1,jsta),TSL(1,jsta),QSL(1,jsta),EGRID1(1,jsta)) + CALL CALRH(EGRID2(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -1307,18 +1288,19 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(017)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(017)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND SAVRH(I,J) = GRID1(I,J) ENDDO ENDDO @@ -1332,7 +1314,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(331)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SPVAL CFRSL(I,J) = MIN(MAX(0.0,CFRSL(I,J)),1.0) IF(abs(CFRSL(I,J)-SPVAL) > SMALL) & @@ -1343,11 +1325,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(331)) fld_info(cfld)%lvl = LVLSXML(LP,IGET(331)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1360,15 +1343,15 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(015)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(I,J) = SPL(LP) ENDDO ENDDO ! - CALL CALDWP(EGRID2(1,jsta),QSL(1,jsta),EGRID1(1,jsta),TSL(1,jsta)) + CALL CALDWP(EGRID2(ista:iend,jsta:jend),QSL(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend),TSL(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TSL(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J) ELSE @@ -1380,11 +1363,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(015)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(015)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1397,7 +1381,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(016)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QSL(I,J) ENDDO ENDDO @@ -1406,11 +1390,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(016)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(016)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1423,7 +1408,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(020)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = OSL(I,J) ENDDO ENDDO @@ -1449,11 +1434,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(020)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(020)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1466,7 +1452,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(284)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = WSL(I,J) ENDDO ENDDO @@ -1474,11 +1460,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(284)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(284)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1489,28 +1476,29 @@ SUBROUTINE MDL2P(iostatusD3D) ! IF(IGET(085) > 0)THEN IF(LVLS(LP,IGET(085)) > 0)THEN - CALL CALMCVG(QSL(1,jsta_2l),USL(1,jsta_2l),VSL(1,jsta_2l),EGRID1(1,jsta_2l)) + CALL CALMCVG(QSL(ista_2l,jsta_2l),USL(ista_2l,jsta_2l),VSL(ista_2l,jsta_2l),EGRID1(ista_2l,jsta_2l)) ! if(me == 0) print *,'after calmcvgme=',me,'USL=',USL(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO !MEB NOT SURE IF I STILL NEED THIS ! CONVERT TO DIVERGENCE FOR GRIB UNITS ! -! CALL SCLFLD(GRID1,-1.0,IM,JM) +! CALL SCLFLD(GRID1(ista:iend,jsta:jend),-1.0,IM,JM) !MEB NOT SURE IF I STILL NEED THIS if(grib == 'grib2')then cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(085)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(085)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo ! if(me==0) print *,'in mdl2p,mconv, lp=',fld_info(cfld)%lvl,'lp=',lp @@ -1531,7 +1519,7 @@ SUBROUTINE MDL2P(iostatusD3D) if ( log1 ) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = USL(I,J) GRID2(I,J) = VSL(I,J) ENDDO @@ -1554,22 +1542,24 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(018)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(018)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(019)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(019)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -1584,7 +1574,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! print *,'me=',me,'EGRID1=',EGRID1(1:10,JSTA) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1610,11 +1600,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(021)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(021)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1626,16 +1617,16 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(086)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Q2SL(I,J) ENDDO ENDDO @@ -1672,11 +1664,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(022)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(022)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1691,7 +1684,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! GFS does not seperate cloud water from ice, hoping to do that in Feb 08 implementation !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(QW1(I,J) < SPVAL .AND. QI1(I,J) < SPVAL) THEN GRID1(I,J) = QW1(I,J) + QI1(I,J) QI1(I,J) = spval @@ -1703,7 +1696,7 @@ SUBROUTINE MDL2P(iostatusD3D) ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QW1(I,J) ENDDO ENDDO @@ -1712,11 +1705,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(153)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(153)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1729,7 +1723,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(166)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QI1(I,J) ENDDO ENDDO @@ -1737,11 +1731,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(166)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(166)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1753,7 +1748,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(183)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QR1(I,J) ENDDO ENDDO @@ -1761,11 +1756,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(183)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(183)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1777,7 +1773,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(184)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QS1(I,J) ENDDO ENDDO @@ -1785,11 +1781,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(184)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(184)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1801,7 +1798,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(416)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QG1(I,J) ENDDO ENDDO @@ -1809,11 +1806,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(416)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(416)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1826,7 +1824,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(198)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = C1D(I,J) ENDDO ENDDO @@ -1834,11 +1832,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(198)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(198)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1850,7 +1849,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(263)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FRIME(I,J) ENDDO ENDDO @@ -1858,11 +1857,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(263)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(263)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1874,7 +1874,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(294)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RAD(I,J) ENDDO ENDDO @@ -1882,11 +1882,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(294)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(294)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1898,7 +1899,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(251)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DBZ1(I,J) ENDDO ENDDO @@ -1906,11 +1907,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(251)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(251)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1920,11 +1922,11 @@ SUBROUTINE MDL2P(iostatusD3D) !--- IN-FLIGHT ICING CONDITION: ADD BY B. ZHOU IF(IGET(257) > 0)THEN IF(LVLS(LP,IGET(257)) > 0)THEN - CALL CALICING(TSL(1,jsta), SAVRH, OSL(1,jsta), EGRID1(1,jsta)) + CALL CALICING(TSL(ista:iend,jsta:jend), SAVRH, OSL(ista:iend,jsta:jend), EGRID1(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1932,11 +1934,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(257)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(257)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1951,7 +1954,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF(LVLS(LP,IGET(258)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J) 3. .OR. GRID1(I,J) < 0.) ! + print*,'bad CAT',i,j,GRID1(I,J) @@ -1975,11 +1978,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(258)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(258)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1990,7 +1994,7 @@ SUBROUTINE MDL2P(iostatusD3D) !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U USL_OLD(I,J) = USL(I,J) VSL_OLD(I,J) = VSL(I,J) IF(FSL(I,J) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = O3SL(I,J) ENDDO ENDDO @@ -2016,11 +2020,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(268)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(268)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2032,7 +2037,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(738)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SMOKESL(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,1) ENDDO ENDDO @@ -2068,11 +2074,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(438)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(438)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2083,7 +2090,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(439)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,2) ENDDO ENDDO @@ -2091,11 +2098,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(439)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(439)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2106,7 +2114,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(440)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,3) ENDDO ENDDO @@ -2114,11 +2122,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(440)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(440)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2129,7 +2138,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(441)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,4) ENDDO ENDDO @@ -2137,11 +2146,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(441)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(441)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2152,7 +2162,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(442)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DUSTSL(I,J,5) ENDDO ENDDO @@ -2160,11 +2170,12 @@ SUBROUTINE MDL2P(iostatusD3D) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(442)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(442)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2179,7 +2190,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(355)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,1) ENDDO ENDDO @@ -2211,11 +2222,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2226,7 +2238,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(354)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,2) ENDDO ENDDO @@ -2258,11 +2270,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2273,7 +2286,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(356)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,3) ENDDO ENDDO @@ -2305,11 +2318,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2320,7 +2334,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(357)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,4) ENDDO ENDDO @@ -2352,11 +2366,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2367,7 +2382,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(358)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,5) ENDDO ENDDO @@ -2399,11 +2414,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2414,7 +2430,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(359)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,6) ENDDO ENDDO @@ -2446,11 +2462,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2461,7 +2478,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(360)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,7) ENDDO ENDDO @@ -2493,11 +2510,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2508,7 +2526,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(361)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,8) ENDDO ENDDO @@ -2540,11 +2558,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2555,7 +2574,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(362)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,9) ENDDO ENDDO @@ -2587,11 +2606,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2602,7 +2622,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(363)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,10) ENDDO ENDDO @@ -2635,11 +2655,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2650,7 +2671,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(364)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,11) ENDDO ENDDO @@ -2683,11 +2704,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2698,7 +2720,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(365)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,12) ENDDO ENDDO @@ -2731,11 +2753,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2746,7 +2769,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(366)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,13) ENDDO ENDDO @@ -2779,11 +2802,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2794,7 +2818,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(367)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,14) ENDDO ENDDO @@ -2827,11 +2851,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2842,7 +2867,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(368)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,15) ENDDO ENDDO @@ -2875,11 +2900,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2890,7 +2916,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(369)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,16) ENDDO ENDDO @@ -2922,11 +2948,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2937,7 +2964,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(370)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,17) ENDDO ENDDO @@ -2970,11 +2997,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2985,7 +3013,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(371)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,18) ENDDO ENDDO @@ -3018,11 +3046,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3033,7 +3062,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(372)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,19) ENDDO ENDDO @@ -3065,11 +3094,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3080,7 +3110,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(373)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,20) ENDDO ENDDO @@ -3113,11 +3143,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3128,7 +3159,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(374)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,21) ENDDO ENDDO @@ -3161,11 +3192,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3176,7 +3208,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(375)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,22) ENDDO ENDDO @@ -3208,11 +3240,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3223,7 +3256,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(379)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(D3DSL(i,j,1)/=SPVAL)THEN GRID1(I,J) = D3DSL(i,j,1) + D3DSL(i,j,2) & + D3DSL(i,j,3) + D3DSL(i,j,4) & @@ -3261,11 +3294,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3276,7 +3310,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(391)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,23) ENDDO ENDDO @@ -3309,11 +3343,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3324,7 +3359,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(392)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,24) ENDDO ENDDO @@ -3357,11 +3392,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3372,7 +3408,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(393)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,25) ENDDO ENDDO @@ -3405,11 +3441,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3420,7 +3457,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(394)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,26) ENDDO ENDDO @@ -3453,11 +3490,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3468,7 +3506,7 @@ SUBROUTINE MDL2P(iostatusD3D) IF (LVLS(LP,IGET(395)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = D3DSL(i,j,27) ENDDO ENDDO @@ -3501,11 +3539,12 @@ SUBROUTINE MDL2P(iostatusD3D) fld_info(cfld)%ntrange=(IFHR-ID(18))/ITD3D endif fld_info(cfld)%tinvstat=ITD3D -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3515,7 +3554,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! CHUANG: COMPUTE HAINES INDEX IF (IGET(455) > 0) THEN - ii=im/2+100 + ii=(ista+iend)/2+100 jj=(jsta+jend)/2-100 IF(ABS(SPL(LP)-50000.) 17. .AND. DUM1 <= 21.) THEN - ISTA = 2 + ISTAA = 2 ELSE - ISTA = 3 + ISTAA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <= 14.) THEN @@ -3551,7 +3590,7 @@ SUBROUTINE MDL2P(iostatusD3D) IMOIS = 3 END IF IF(TSL(I,J) 5. .AND. DUM1 <= 10.) THEN - ISTA = 2 + ISTAA = 2 ELSE - ISTA = 3 + ISTAA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <= 5.) THEN @@ -3597,7 +3636,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! if(i==570 .and. j==574)print*,'mid haines index:',i,j,luhi,tsl(i,j) & ! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) IF(TSL(I,J) 3. .AND. DUM1 <=7. ) THEN - ISTA = 2 + ISTAA = 2 ELSE - ISTA = 3 + ISTAA = 3 END IF DUM1 = TSL(I,J)-TDSL(I,J) IF(DUM1 <=5. ) THEN @@ -3641,7 +3680,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! if(i==570 .and. j==574)print*,'low haines index:',i,j,luhi,tsl(i,j) & ! ,tprs(i,j,luhi),tdsl(i,j),ista,imois,spl(luhi),spl(lp),haines(i,j) IF(TSL(I,J) WONT DERIVE MESINGER SLP' END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PSLP(I,J) ENDDO ENDDO @@ -3795,11 +3838,12 @@ SUBROUTINE MDL2P(iostatusD3D) if(grib == 'grib2')then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(023)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3811,18 +3855,19 @@ SUBROUTINE MDL2P(iostatusD3D) CALL MAPSSLP(TPRS) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PSLP(I,J) ENDDO ENDDO if(grib == 'grib2') then cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(445)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3843,7 +3888,7 @@ SUBROUTINE MDL2P(iostatusD3D) ! because MOS can't adjust to the much lower H !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL1(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AKH(I,J) ENDDO ENDDO if(grib=="grib2" )then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' @@ -353,7 +354,7 @@ SUBROUTINE MDL2SIGMA NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U ! TSL(I,J)=SPVAL @@ -407,7 +408,7 @@ SUBROUTINE MDL2SIGMA !hc J=JHOLD(NN) DO 220 J=JSTA,JEND ! Moorthi on Nov 26 2014 ! DO 220 J=JSTA_2L,JEND_2U - DO 220 I=1,IM + DO 220 I=ISTA,IEND LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -555,7 +556,7 @@ SUBROUTINE MDL2SIGMA ! ! OBTAIN GEOPOTENTIAL AND KH ON INTERFACES DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U FSL(I,J)=SPVAL AKH(I,J)=SPVAL NL1XF(I,J)=LP1 @@ -571,7 +572,7 @@ SUBROUTINE MDL2SIGMA ! ! DO J=JSTA_2L,JEND_2U DO J=JSTA,JEND ! Moorthi on 26 Nov 2014 - DO I=1,IM + DO I=ISTA,IEND DONEFSL1=.FALSE. TSLDONE=.FALSE. LLMH = NINT(LMH(I,J)) @@ -721,22 +722,41 @@ SUBROUTINE MDL2SIGMA ! VERTICAL INTERPOLATION FOR WIND FOR E and B GRIDS ! if(gridtype=='B' .or. gridtype=='E') & - call exch(PINT(1:IM,JSTA_2L:JEND_2U,LP1)) + call exch(PINT(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LP1)) IF(gridtype=='E')THEN DO J=JSTA,JEND - DO I=1,IM-MOD(J,2) +! DO I=1,IM-MOD(J,2) + DO I=ISTA,IEND-MOD(J,2) !Jesse 20211014 ! !*** LOCATE VERTICAL INDEX OF MODEL MIDLAYER FOR V POINT JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! LLMH = NINT(LMH(I,J)) - IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC + +!Jesse 20211014 +! IF(J == 1 .AND. I < IM)THEN !SOUTHERN BC +! PDV=0.5*(PINT(I,J,LLMH+1)+PINT(I+1,J,LLMH+1)) +! ELSE IF(J==JM .AND. I0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FSL(I,J)0) THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AKH(I,J) IF(LP==(LSIG+1))GRID1(I,J)=0.0 !! NO SLIP ASSUMTION FOR CMAQ ENDDO @@ -962,7 +1004,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(243)) fld_info(cfld)%lvl=LVLSXML(LP+1,IGET(243)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif if(me==0)print*,'output Heat Diffusivity' ENDIF @@ -973,7 +1015,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(206)>0) THEN IF(LVLS(LP,IGET(206))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -981,7 +1023,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(206)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(206)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -992,7 +1034,7 @@ SUBROUTINE MDL2SIGMA IF(LVLS(LP,IGET(216))>0)THEN !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLMH = NINT(LMH(I,J)) GRID1(I,J)=PTSIGO+ASIGO(LP)*(PINT(I,J,LLMH+1)-PTSIGO) ENDDO @@ -1001,7 +1043,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(216)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(216)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1011,7 +1053,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(207)>0)THEN IF(LVLS(LP,IGET(207))>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QSL(I,J) ENDDO ENDDO @@ -1020,7 +1062,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(207)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(207)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1030,7 +1072,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(210)>0)THEN IF(LVLS(LP,IGET(210))>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=OSL(I,J) ENDDO ENDDO @@ -1038,7 +1080,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(210)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(210)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1048,7 +1090,7 @@ SUBROUTINE MDL2SIGMA IF(IGET(208)>0.OR.IGET(209)>0)THEN IF(LVLS(LP,IGET(208))>0.OR.LVLS(LP,IGET(209))>0) then DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=USL(I,J) GRID2(I,J)=VSL(I,J) ENDDO @@ -1057,11 +1099,11 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(208)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(208)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(209)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(209)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID2(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1071,7 +1113,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(217)>0) THEN IF (LVLS(LP,IGET(217))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=Q2SL(I,J) ENDDO ENDDO @@ -1079,7 +1121,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(217)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(217)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1089,7 +1131,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(211)>0) THEN IF (LVLS(LP,IGET(211))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QW1(I,J) ENDDO ENDDO @@ -1097,7 +1139,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(211)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(211)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1107,7 +1149,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(212)>0) THEN IF (LVLS(LP,IGET(212))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QI1(I,J) ENDDO ENDDO @@ -1115,7 +1157,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(212)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(212)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1124,7 +1166,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(213)>0) THEN IF (LVLS(LP,IGET(213))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QR1(I,J) ENDDO ENDDO @@ -1132,7 +1174,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(213)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(213)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1141,7 +1183,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(214)>0) THEN IF (LVLS(LP,IGET(214))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QS1(I,J) ENDDO ENDDO @@ -1149,7 +1191,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(214)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(214)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1158,7 +1200,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(255)>0) THEN IF (LVLS(LP,IGET(255))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QG1(I,J) ENDDO ENDDO @@ -1166,7 +1208,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(255)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(255)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1175,7 +1217,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(215)>0) THEN IF (LVLS(LP,IGET(215))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=C1D(I,J) ENDDO ENDDO @@ -1183,7 +1225,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(215)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(215)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1192,7 +1234,7 @@ SUBROUTINE MDL2SIGMA IF (IGET(222)>0) THEN IF (LVLS(LP,IGET(222))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=CFRSIG(I,J) ENDDO ENDDO @@ -1200,7 +1242,7 @@ SUBROUTINE MDL2SIGMA cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(222)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(222)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF diff --git a/sorc/ncep_post.fd/MDL2SIGMA2.f b/sorc/ncep_post.fd/MDL2SIGMA2.f index 1efa8da73..a02107e10 100644 --- a/sorc/ncep_post.fd/MDL2SIGMA2.f +++ b/sorc/ncep_post.fd/MDL2SIGMA2.f @@ -20,6 +20,7 @@ !! 20-03-25 J MENG - remove grib1 !! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) !! 21-07-26 W Meng - Restrict compuatation from undefined grids +!! 21-10-14 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDL2P !! INPUT ARGUMENT LIST: @@ -50,7 +51,8 @@ SUBROUTINE MDL2SIGMA2 use masks, only: lmh use params_mod, only: pq0, a2, a3, a4, rgamog use ctlblk_mod, only: pt, jsta_2l, jend_2u, spval, lp1, lm, jsta, jend,& - grib, cfld, datapd, fld_info, im, jm, im_jm + grib, cfld, datapd, fld_info, im, jm, im_jm, & + ista, iend, ista_2l, iend_2u use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml ! implicit none @@ -61,12 +63,12 @@ SUBROUTINE MDL2SIGMA2 ! LOGICAL READTHK ! REAL,dimension(im,jm) :: FSL, TSL, QSL, osl, usl, vsl, q2sl, fsl1, & - REAL,dimension(im,jsta_2l:jend_2u) :: TSL - REAL,dimension(im,jsta_2l:jend_2u) :: grid1 + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: TSL + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1 REAL SIGO(LSIG+1),DSIGO(LSIG),ASIGO(LSIG) ! ! INTEGER,dimension(im,jm) :: IHOLD,JHOLD,NL1X,NL1XF - INTEGER,dimension(im,jsta_2l:jend_2u) :: NL1X + INTEGER,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: NL1X ! ! !--- Definition of the following 2D (horizontal) dummy variables @@ -134,7 +136,7 @@ SUBROUTINE MDL2SIGMA2 NHOLD=0 ! DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U ! TSL(I,J)=SPVAL @@ -175,7 +177,7 @@ SUBROUTINE MDL2SIGMA2 ! DO 220 J=JSTA,JEND ! DO 220 J=JSTA_2L,JEND_2U DO 220 J=JSTA,JEND ! Moorthi on Nov 26, 2014 - DO 220 I=1,IM + DO 220 I=ISTA,IEND LL=NL1X(I,J) !--------------------------------------------------------------------- !*** VERTICAL INTERPOLATION OF GEOPOTENTIAL, TEMPERATURE, SPECIFIC @@ -264,7 +266,7 @@ SUBROUTINE MDL2SIGMA2 IF(IGET(296)>0) THEN IF(LVLS(LP,IGET(296))>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=TSL(I,J) ENDDO ENDDO @@ -272,7 +274,7 @@ SUBROUTINE MDL2SIGMA2 cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(296)) fld_info(cfld)%lvl=LVLSXML(LP,IGET(296)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF diff --git a/sorc/ncep_post.fd/MDL2STD_P.f b/sorc/ncep_post.fd/MDL2STD_P.f index bcb81f375..ee5ff8a94 100644 --- a/sorc/ncep_post.fd/MDL2STD_P.f +++ b/sorc/ncep_post.fd/MDL2STD_P.f @@ -1,40 +1,19 @@ !> @file -! . . . -!> SUBPROGRAM: MDL2STD_P VERT INTRP OF MODEL LVLS TO STANDARD ATMOSPEHRIC PRESSURE -!! PRGRMMR: Y Mao ORG: W/NP22 DATE: Sep 2019 -!! -!! ABSTRACT: -!! ORIGINATED FROM MISCLN.f. THIS ROUTINE INTERPOLATE TO STANDARD -!! ATMOSPHERIC PRESSURE, INSTEAD OF MODEL PRESSURE -!! -!! PROGRAM HISTORY LOG: -!! 19-09-24 Y Mao - REWRITTEN FROM MISCLN.f -!! 20-05-20 J MENG - CALRH unification with NAM scheme -!! 20-11-10 J MENG - USE UPP_PHYSICS MODULE -!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) -!! -!! USAGE: CALL MDL2STD_P -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! FDLVL_UV - COMPUTE FD LEVEL WIND (AGL OR MSL). -!! FDLVL_MASS - COMPUTE FD LEVEL MASS (AGL OR MSL). -!! -!! LIBRARY: -!! COMMON - CTLBLK -!! RQSTFLD -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief mdl2std_p() vert intrp of model lvls to standard atmospheric pressure. +!> +!> Originated from MISCLN.f. This routine interpolate to standard +!> atmospheric pressure, instead of model pressure. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2019-09-24 | Y Mao | Rewritten from MISCLN.f +!> 2020-05-20 | J Meng | CALRH unification with NAM scheme +!> 2020-11-10 | J Meng | Use UPP_PHYSICS Module +!> 2021-03-11 | B Cui | Change local arrays to dimension (im,jsta:jend) +!> 2021-10-14 | J MENG | 2D DECOMPOSITION +!> +!> @author Y Mao W/NP22 @date 2019-09-24 SUBROUTINE MDL2STD_P() ! @@ -44,10 +23,11 @@ SUBROUTINE MDL2STD_P() use vrbls3d, only: ICING_GFIP, ICING_GFIS, catedr, mwt, gtg use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, & lm, htfd, spval, nfd, me,& - jsta_2l, jend_2u, MODELNAME + jsta_2l, jend_2u, MODELNAME,& + ista, iend, ista_2l, iend_2u use rqstfld_mod, only: iget, lvls, iavblfld, lvlsxml use grib2_module, only: pset - use upp_physics, only: CALRH + use upp_physics, only: CALRH, CALVOR !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! @@ -55,11 +35,11 @@ SUBROUTINE MDL2STD_P() real, external :: P2H, relabel - real,dimension(im,jsta_2l:jend_2u) :: grid1 - real,dimension(im,jsta_2l:jend_2u) :: EGRID1,EGRID2,EGRID3,EGRID4 + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid1 + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: EGRID1,EGRID2,EGRID3,EGRID4 ! - integer I,J,jj,L,ITYPE,IFD,ITYPEFDLVL(NFD) + integer I,J,ii,jj,L,ITYPE,IFD,ITYPEFDLVL(NFD) ! Variables introduced to allow FD levels from control file - Y Mao integer :: N,NFDCTL @@ -119,8 +99,8 @@ SUBROUTINE MDL2STD_P() ENDDO if(allocated(VAR3D1)) deallocate(VAR3D1) if(allocated(VAR3D2)) deallocate(VAR3D2) - allocate(VAR3D1(IM,JSTA_2L:JEND_2U,NFDCTL)) - allocate(VAR3D2(IM,JSTA_2L:JEND_2U,NFDCTL)) + allocate(VAR3D1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFDCTL)) + allocate(VAR3D2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFDCTL)) VAR3D1=SPVAL VAR3D2=SPVAL @@ -131,7 +111,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(520)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=VAR3D1(I,J,IFD) ENDDO ENDDO @@ -139,11 +119,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(520)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(520)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -152,7 +133,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(521)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=VAR3D2(I,J,IFD) ENDDO ENDDO @@ -160,23 +141,24 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(521)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(521)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ENDIF ! ABSV IF (LVLS(IFD,IGET(524)) > 0) THEN - EGRID1=VAR3D1(1:IM,JSTA_2L:JEND_2U,IFD) - EGRID2=VAR3D2(1:IM,JSTA_2L:JEND_2U,IFD) + EGRID1=VAR3D1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,IFD) + EGRID2=VAR3D2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,IFD) call CALVOR(EGRID1,EGRID2,EGRID3) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=EGRID3(I,J) ENDDO ENDDO @@ -184,11 +166,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(524)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(524)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -206,7 +189,7 @@ SUBROUTINE MDL2STD_P() if(allocated(QIN)) deallocate(QIN) if(allocated(QTYPE)) deallocate(QTYPE) - ALLOCATE(QIN(IM,JSTA:JEND,LM,NFDMAX)) + ALLOCATE(QIN(ISTA:IEND,JSTA:JEND,LM,NFDMAX)) ALLOCATE(QTYPE(NFDMAX)) ! INITIALIZE INPUTS @@ -214,53 +197,53 @@ SUBROUTINE MDL2STD_P() IF(IGET(450) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 450 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=icing_gfip(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=icing_gfip(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(480) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 480 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=icing_gfis(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=icing_gfis(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(464) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 464 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=gtg(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=gtg(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(465) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 465 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=catedr(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=catedr(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(466) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 466 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=mwt(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=mwt(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="O" end if IF(IGET(519) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 519 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=T(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=T(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="T" end if IF(IGET(523) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 523 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=OMGA(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=OMGA(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="W" end if IF(IGET(525) > 0) THEN nFDS = nFDS + 1 IDS(nFDS) = 525 - QIN(1:IM,JSTA:JEND,1:LM,nFDS)=QQW(1:IM,JSTA:JEND,1:LM)+ & - QQR(1:IM,JSTA:JEND,1:LM)+ & - QQS(1:IM,JSTA:JEND,1:LM)+ & - QQG(1:IM,JSTA:JEND,1:LM)+ & - QQI(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,nFDS)=QQW(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQR(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQS(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQG(ISTA:IEND,JSTA:JEND,1:LM)+ & + QQI(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(nFDS)="C" end if @@ -281,7 +264,7 @@ SUBROUTINE MDL2STD_P() ENDDO if(allocated(QFD)) deallocate(QFD) - ALLOCATE(QFD(IM,JSTA:JEND,NFDCTL,nFDS)) + ALLOCATE(QFD(ISTA:IEND,JSTA:JEND,NFDCTL,nFDS)) QFD=SPVAL call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,pset%param(N)%level,HTFDCTL,nFDS,QIN,QTYPE,QFD) @@ -296,7 +279,7 @@ SUBROUTINE MDL2STD_P() N1=N DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD,N) < SPVAL) then QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N)) QFD(I,J,IFD,N)=min(1.0,QFD(I,J,IFD,N)) @@ -311,7 +294,7 @@ SUBROUTINE MDL2STD_P() N1=N DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD,N) < SPVAL) then QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N)) endif @@ -330,7 +313,7 @@ SUBROUTINE MDL2STD_P() if(iID==480) then DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(N1 > 0) then ! Icing severity is 0 when icing potential is too small if(QFD(I,J,IFD,N1) < 0.001) QFD(I,J,IFD,N)=0. @@ -356,7 +339,7 @@ SUBROUTINE MDL2STD_P() if(iID==464 .or. iID==465 .or. iID==466) then DO IFD = 1,NFDCTL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(QFD(I,J,IFD,N) < SPVAL) then QFD(I,J,IFD,N)=max(0.0,QFD(I,J,IFD,N)) QFD(I,J,IFD,N)=min(1.0,QFD(I,J,IFD,N)) @@ -375,7 +358,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(iID)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QFD(I,J,IFD,N) ENDDO ENDDO @@ -383,11 +366,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(iID)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -417,7 +401,7 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(iID)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=HTFDCTL(IFD) ENDDO ENDDO @@ -425,11 +409,12 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(iID)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -456,15 +441,15 @@ SUBROUTINE MDL2STD_P() if(allocated(QIN)) deallocate(QIN) if(allocated(QTYPE)) deallocate(QTYPE) - ALLOCATE(QIN(IM,JSTA:JEND,LM,2)) + ALLOCATE(QIN(ISTA:IEND,JSTA:JEND,LM,2)) ALLOCATE(QTYPE(2)) - QIN(1:IM,JSTA:JEND,1:LM,1)=T(1:IM,JSTA:JEND,1:LM) - QIN(1:IM,JSTA:JEND,1:LM,2)=Q(1:IM,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,1)=T(ISTA:IEND,JSTA:JEND,1:LM) + QIN(ISTA:IEND,JSTA:JEND,1:LM,2)=Q(ISTA:IEND,JSTA:JEND,1:LM) QTYPE(1)="T" QTYPE(2)="Q" if(allocated(QFD)) deallocate(QFD) - ALLOCATE(QFD(IM,JSTA:JEND,NFDCTL,2)) + ALLOCATE(QFD(ISTA:IEND,JSTA:JEND,NFDCTL,2)) QFD=SPVAL print *, "wafs levels",pset%param(N)%level @@ -476,20 +461,20 @@ SUBROUTINE MDL2STD_P() IF (LVLS(IFD,IGET(iID)) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(I,J) = HTFDCTL(IFD) ! P ENDDO ENDDO - EGRID3(1:IM,JSTA:JEND)=QFD(1:IM,JSTA:JEND,IFD,1) ! T - EGRID4(1:IM,JSTA:JEND)=QFD(1:IM,JSTA:JEND,IFD,2) ! Q + EGRID3(ISTA:IEND,JSTA:JEND)=QFD(ISTA:IEND,JSTA:JEND,IFD,1) ! T + EGRID4(ISTA:IEND,JSTA:JEND)=QFD(ISTA:IEND,JSTA:JEND,IFD,2) ! Q EGRID1 = SPVAL - CALL CALRH(EGRID2(1,jsta),EGRID3(1,jsta),EGRID4(1,jsta),EGRID1(1,jsta)) + CALL CALRH(EGRID2(ista:iend,jsta:jend),EGRID3(ista:iend,jsta:jend),EGRID4(ista:iend,jsta:jend),EGRID1(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(EGRID1(I,J) < SPVAL) THEN GRID1(I,J) = EGRID1(I,J)*100. ELSE @@ -502,10 +487,11 @@ SUBROUTINE MDL2STD_P() cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(iID)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(iID)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=1,iend-ista+1 + ii = ista+i-1 datapd(i,j,cfld) = GRID1(i,jj) enddo enddo diff --git a/sorc/ncep_post.fd/MDL2THANDPV.f b/sorc/ncep_post.fd/MDL2THANDPV.f index bc5d6efef..8d70c2ee4 100644 --- a/sorc/ncep_post.fd/MDL2THANDPV.f +++ b/sorc/ncep_post.fd/MDL2THANDPV.f @@ -1,44 +1,24 @@ !> @file -! -!> SUBPROGRAM: MDL2THANDPV VERT INTRP OF MODEL LVLS TO ISENTROPIC AND PV -!! PRGRMMR: CHUANG ORG: W/NP22 DATE: 07-03-26 -!! -!! ABSTRACT: -!! FOR MOST APPLICATIONS THIS ROUTINE IS THE WORKHORSE -!! OF THE POST PROCESSOR. IN A NUTSHELL IT INTERPOLATES -!! DATA FROM MODEL TO THETA AND PV SURFACES. -!! -!! PROGRAM HISTORY -!! 11-02-06 J. WANG ADD GRIB2 OPTION -!! 14-03-06 S. Moorthi - updated for threading and some optimization -!! 16-12-19 G.P. Lou - Added A-grid regional models -!! 20-03-25 J MENG - remove grib1 -!! 20-03-25 J MENG - remove grib1 -!! 20-11-10 J MENG - USE UPP_MATH and UPP_PHYSICS MODULES -!! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) -!! -!! -!! USAGE: CALL MDL2THANDPV -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! PVETC - -!! P2TH - -!! P2PV - -!! COMMON - CTLBLK -!! RQSTFLD -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! +!> @brief mdl2thandpv() vert intrp of model lvls to isentropic and PV. +!> +!> For most applications this routine is the workhorse +!> of the post processor. In a nutshell it interpolates +!> data from model to THETA and PV surfaces. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2007-03-26 | Chuang | Initial +!> 2011-02-06 | J. Wang | Add GRIB2 Option +!> 2014-03-06 | S. Moorthi | Updated for threading and some optimization +!> 2016-12-19 | G.P. Lou | Added A-grid regional models +!> 2020-03-25 | J Meng | Remove grib1 +!> 2020-03-25 | J Meng | Remove grib1 +!> 2020-11-10 | J Meng | Use UPP_MATH and UPP_PHYSICS Modules +!> 2021-03-11 | B Cui | Change local arrays to dimension (im,jsta:jend) +!> 2021-10-26 | J MENG | 2D DECOMPOSITION +!> +!> @author Chuang W/NP22 @date 2007-03-26 SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! @@ -48,8 +28,9 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) use masks, only: gdlat, gdlon, dx, dy use physcons_post, only: con_eps, con_epsm1 use params_mod, only: dtr, small, erad, d608, rhmin - use CTLBLK_mod, only: spval, lm, jsta_2l, jend_2u, jsta_2l, grib, cfld, datapd, fld_info,& - im, jm, jsta, jend, jsta_m, jend_m, modelname, global,gdsdegr,me + use CTLBLK_mod, only: spval, lm, jsta_2l, jend_2u, grib, cfld, datapd, fld_info,& + im, jm, jsta, jend, jsta_m, jend_m, modelname, global,gdsdegr,me,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u use RQSTFLD_mod, only: iget, lvls, id, iavblfld, lvlsxml use gridspec_mod, only: gridtype,dyval use upp_physics, only: FPVSNEW @@ -61,7 +42,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! integer,intent(in) :: kth, kpv real, intent(in) :: th(kth), pv(kpv) - real, dimension(im,jsta:jend) :: grid1, grid2 + real, dimension(ista:iend,jsta:jend) :: grid1, grid2 real, dimension(kpv) :: pvpt, pvpb LOGICAL IOOMG,IOALL @@ -72,11 +53,14 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) , DUM1D9(:), DUM1D10(:),DUM1D11(:) & , DUM1D12(:),DUM1D13(:),DUM1D14(:) ! - real, dimension(IM,JSTA:JEND,KTH) :: UTH, VTH, HMTH, TTH, PVTH, & + real, dimension(ISTA:IEND,JSTA:JEND,KTH) :: UTH, VTH, HMTH, TTH, PVTH, & SIGMATH, RHTH, OTH - real, dimension(IM,JSTA:JEND,KPV) :: UPV, VPV, HPV, TPV, PPV, SPV + real, dimension(ISTA:IEND,JSTA:JEND,KPV) :: UPV, VPV, HPV, TPV, PPV, SPV + real, dimension(IM,2) :: GLATPOLES, COSLPOLES, PVPOLES + real, dimension(IM,2,LM) :: UPOLES, TPOLES, PPOLES + real, dimension(IM,JSTA:JEND) :: COSLTEMP, PVTEMP ! - real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), wrk4(:,:), cosl(:,:) + real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), wrk4(:,:), cosl(:,:), dum2d(:,:) real, allocatable :: tuv(:,:,:),pmiduv(:,:,:) ! integer, dimension(im) :: iw, ie @@ -88,7 +72,9 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) !****************************************************************************** ! ! START MDL2TH. -! +! + if(me==0) write(0,*) 'MDL2THANDPV starts' +! ! SET TOTAL NUMBER OF POINTS ON OUTPUT GRID. ! !--------------------------------------------------------------- @@ -119,7 +105,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) do k=1,kth !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend UTH(i,j,k) = SPVAL VTH(i,j,k) = SPVAL HMTH(i,j,k) = SPVAL @@ -134,7 +120,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) do k=1,kpv !$omp parallel do private(i,j) do j=jsta,jend - do i=1,im + do i=ista,iend UPV(i,j,k) = SPVAL VPV(i,j,k) = SPVAL HPV(i,j,k) = SPVAL @@ -151,20 +137,24 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ALLOCATE(DUM1D14(LM)) ! DO L=1,LM - CALL EXCH(PMID(1:IM,JSTA_2L:JEND_2U,L)) - CALL EXCH(T(1:IM,JSTA_2L:JEND_2U,L)) - CALL EXCH(UH(1:IM,JSTA_2L:JEND_2U,L)) + CALL EXCH(PMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) + CALL EXCH(T(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) + CALL EXCH(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) + CALL EXCH(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) END DO - CALL EXCH(GDLAT(1,JSTA_2L)) + CALL EXCH(GDLAT(ISTA_2L,JSTA_2L)) + CALL EXCH(GDLON(ISTA_2L,JSTA_2L)) ! print *,' JSTA_2L=',JSTA_2L,' JSTA=',JSTA_2L,' JEND_2U=', & ! &JEND_2U,' JEND=',JEND,' IM=',IM ! print *,' GDLATa=',gdlat(1,:) ! print *,' GDLATb=',gdlat(im,:) ! - allocate (wrk1(im,jsta:jend), wrk2(im,jsta:jend), & - & wrk3(im,jsta:jend), cosl(im,jsta_2l:jend_2u)) - allocate (wrk4(im,jsta:jend)) + allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), & + & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate (dum2d(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate (wrk4(ista:iend,jsta:jend)) + imb2 = im /2 eradi = 1.0 / erad @@ -175,12 +165,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ie(i) = i + 1 iw(i) = i - 1 enddo - iw(1) = im - ie(im) = 1 +! iw(1) = im +! ie(im) = 1 ! !$omp parallel do private(i,j,ip1,im1) DO J=JSTA,JEND - do i=1,im + do i=ISTA,IEND ip1 = ie(i) im1 = iw(i) cosl(i,j) = cos(gdlat(i,j)*dtr) @@ -197,27 +187,31 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) wrk4(i,j) = wrk1(i,j) * wrk2(i,j) ! 1/dx enddo enddo -! CALL EXCH(cosl(1,JSTA_2L)) CALL EXCH(cosl) + + call fullpole(cosl,coslpoles) + call fullpole(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles) !$omp parallel do private(i,j,ii,tem) DO J=JSTA,JEND if (j == 1) then - do i=1,im + do i=ISTA,IEND ii = i + imb2 if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi + ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GLATPOLES(II,1))*DTR) !1/dphi enddo elseif (j == JM) then - do i=1,im + do i=ISTA,IEND ii = i + imb2 if (ii > im) ii = ii - im - wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) !1/dphi + ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) !1/dphi + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GLATPOLES(II,2))*DTR) !1/dphi enddo else !print *,' j=',j,' GDLATJm1=',gdlat(:,j-1) !print *,' j=',j,' GDLATJp1=',gdlat(:,j+1) - do i=1,im + do i=ISTA,IEND tem = GDLAT(I,J-1) - GDLAT(I,J+1) if (abs(tem) > small) then wrk3(i,j) = 1.0 / (tem*DTR) !1/dphi @@ -232,7 +226,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) else !!global? !$omp parallel do private(i,j) DO J=JSTA_m,Jend_m - DO I=2,im-1 + DO I=ISTA_M,IEND_M wrk2(i,j) = 0.5 / DX(I,J) wrk3(i,j) = 0.5 / DY(I,J) END DO @@ -241,20 +235,26 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! need to put T and P on V points for computing dp/dx for e grid IF(GRIDTYPE == 'E')THEN - allocate(tuv(1:im,jsta_2l:jend_2u,lm)) - allocate(pmiduv(1:im,jsta_2l:jend_2u,lm)) + allocate(tuv(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) + allocate(pmiduv(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) do l=1,lm - call h2u(t(1:im,jsta_2l:jend_2u,l),tuv(1:im,jsta_2l:jend_2u,l)) - call h2u(pmid(1:im,jsta_2l:jend_2u,l),pmiduv(1:im,jsta_2l:jend_2u,l)) + call h2u(t(ista_2l:iend_2u,jsta_2l:jend_2u,l),tuv(ista_2l:iend_2u,jsta_2l:jend_2u,l)) + call h2u(pmid(ista_2l:iend_2u,jsta_2l:jend_2u,l),pmiduv(ista_2l:iend_2u,jsta_2l:jend_2u,l)) end do end if !add A-grid regional models IF(GRIDTYPE == 'A')THEN IF(MODELNAME == 'GFS' .or. global) THEN + + DO L=1,LM + CALL FULLPOLE(PMID(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L),PPOLES(:,:,L)) + CALL FULLPOLE( T(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L),TPOLES(:,:,L)) + CALL FULLPOLE( UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L),UPOLES(:,:,L)) + ENDDO !!$omp parallel do private(i,j,ip1,im1,ii,jj,l,es,dum1d1,dum1d2,dum1d3,dum1d4,dum1d5,dum1d6,dum1d14,tem) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ip1 = ie(i) im1 = iw(i) ii = i + imb2 @@ -270,10 +270,13 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DUM1D14(L) = Q(I,J,L) * (PMID(I,J,L)+CON_EPSM1*ES)/(CON_EPS*ES) ! RH DUM1D1(L) = (PMID(ip1,J,L)- PMID(im1,J,L)) * wrk4(i,j) !dp/dx DUM1D3(L) = (T(ip1,J,L) - T(im1,J,L)) * wrk4(i,j) !dt/dx - DUM1D2(L) = (PMID(II,J,L) - PMID(I,J+1,L)) * tem !dp/dy - DUM1D4(L) = (T(II,J,L) - T(I,J+1,L)) * tem !dt/dy + ! DUM1D2(L) = (PMID(II,J,L) - PMID(I,J+1,L)) * tem !dp/dy + DUM1D2(L) = (PPOLES(II,1,L) - PMID(I,J+1,L)) * tem !dp/dy + ! DUM1D4(L) = (T(II,J,L) - T(I,J+1,L)) * tem !dt/dy + DUM1D4(L) = (TPOLES(II,1,L) - T(I,J+1,L)) * tem !dt/dy DUM1D6(L) = ((VH(ip1,J,L)-VH(im1,J,L))*wrk2(i,j) & - & + (UH(II,J,L)*COSL(II,J) & + !& ! + (UH(II,J,L)*COSL(II,J) & + & + (UPOLES(II,1,L)*COSLPOLES(II,1) & & + UH(I,J+1,L)*COSL(I,J+1))*wrk3(i,j))*wrk1(i,j) & & + F(I,J) END DO @@ -305,11 +308,14 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DUM1D14(L) = Q(I,J,L) * (PMID(I,J,L)+CON_EPSM1*ES)/(CON_EPS*ES) ! RH DUM1D1(L) = (PMID(ip1,J,L)- PMID(im1,J,L)) * wrk4(i,j) !dp/dx DUM1D3(L) = (T(ip1,J,L) - T(im1,J,L)) * wrk4(i,j) !dt/dx - DUM1D2(L) = (PMID(I,J-1,L)-PMID(II,J,L)) * tem !dp/dy - DUM1D4(L) = (T(I,J-1,L)-T(II,J,L)) * tem !dt/dy + ! DUM1D2(L) = (PMID(I,J-1,L)-PMID(II,J,L)) * tem !dp/dy + DUM1D2(L) = (PMID(I,J-1,L)-PPOLES(II,2,L)) * tem !dp/dy + ! DUM1D4(L) = (T(I,J-1,L)-T(II,J,L)) * tem !dt/dy + DUM1D4(L) = (T(I,J-1,L)-TPOLES(II,2,L)) * tem !dt/dy DUM1D6(L) = ((VH(ip1,J,L)-VH(im1,J,L))* wrk2(i,j) & & + (UH(I,J-1,L)*COSL(I,J-1) & - & + UH(II,J,L)*COSL(II,J))*wrk3(i,j))*wrk1(i,j) & + !& ! + UH(II,J,L)*COSL(II,J))*wrk3(i,j))*wrk1(i,j) & + & + UPOLES(II,2,L)*COSLPOLES(II,2))*wrk3(i,j))*wrk1(i,j) & & + F(I,J) END DO ELSE !pole point, compute at j=jm-1 @@ -357,7 +363,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DO L=1,LM print*,pmid(i,j,l),dum1d1(l),dum1d2(l),dum1d5(l) & ,dum1d3(l),dum1d4(l),zmid(i,j,l),uh(i,j,l),vh(i,j,l) & - ,dum1d6(l) + ,dum1d6(l),L end do end if @@ -371,7 +377,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,'hm,s,bvf2,pvn,theta,sigma,pvu= ' DO L=1,LM print*,dum1d7(l),dum1d8(l),dum1d9(l),dum1d10(l),dum1d11(l) & - ,dum1d12(l),dum1d13(l) + ,dum1d12(l),dum1d13(l),L end do end if @@ -410,7 +416,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DO J=JSTA_m,Jend_m JMT2=JM/2+1 TPHI=(J-JMT2)*(DYVAL/gdsdegr)*DTR - DO I=2,im-1 + DO I=ISTA_M,IEND_M ip1 = i + 1 im1 = i - 1 tem = wrk3(i,j) * eradi @@ -450,7 +456,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ,'hm,s,bvf2,pvn,theta,sigma,pvu,pvort= ' DO L=1,LM print*,dum1d7(l),dum1d8(l),dum1d9(l),dum1d10(l),dum1d11(l) & - ,dum1d12(l),dum1d13(l),DUM1D6(l) + ,dum1d12(l),dum1d13(l),DUM1D6(l),L end do end if @@ -486,14 +492,15 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ENDIF !regional models and A-grid end here !----------------------------------------------------------------- ELSE IF (GRIDTYPE == 'B')THEN - allocate(DVDXL(1:im,jsta_m:jend_m,lm)) - allocate(DUDYL(1:im,jsta_m:jend_m,lm)) - allocate(UAVGL(1:im,jsta_m:jend_m,lm)) + allocate(DVDXL(ista_m:iend_m,jsta_m:jend_m,lm)) + allocate(DUDYL(ista_m:iend_m,jsta_m:jend_m,lm)) + allocate(UAVGL(ista_m:iend_m,jsta_m:jend_m,lm)) DO L=1,LM - CALL EXCH(VH(1:IM,JSTA_2L:JEND_2U,L)) + CALL EXCH(VH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) + CALL EXCH(UH(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,L)) CALL DVDXDUDY(UH(:,:,L),VH(:,:,L)) DO J=JSTA_m,Jend_m - DO I=2,im-1 + DO I=ISTA_M,IEND_M DVDXL(I,J,L) = DDVDX(I,J) DUDYL(I,J,L) = DDUDY(I,J) UAVGL(I,J,L) = UUAVG(I,J) @@ -503,7 +510,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DO J=JSTA_m,Jend_m JMT2=JM/2+1 TPHI=(J-JMT2)*(DYVAL/gdsdegr)*DTR - DO I=2,im-1 + DO I=ISTA_M,IEND_M ip1 = i + 1 im1 = i - 1 DO L=1,LM @@ -580,7 +587,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) TPHI = (J-JMT2)*(DYVAL/gdsdegr)*DTR IHW= - MOD(J,2) IHE = IHW + 1 - DO I=2,im-1 + DO I=ISTA_M,IEND_M ip1 = i + 1 im1 = i - 1 DO L=1,LM @@ -673,7 +680,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(332)) > 0 .OR. LVLS(LP,IGET(333)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UTH(I,J,LP) GRID2(I,J) = VTH(I,J,LP) ENDDO @@ -682,21 +689,23 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(332)) fld_info(cfld)%lvl = LVLSXML(lp,IGET(332)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET(333)) fld_info(cfld)%lvl = LVLSXML(lp,IGET(333)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -731,7 +740,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! END IF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TTH(I,J,LP) ENDDO ENDDO @@ -739,11 +748,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld = cfld + 1 fld_info(cfld)%ifld=IAVBLFLD(IGET(334)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(334)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -754,14 +764,30 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) ! IF(IGET(335) > 0) THEN IF(LVLS(LP,IGET(335)) > 0)THEN - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & - ,SPVAL,PVTH(1:IM,JSTA:JEND,LP)) - IF(1>=jsta .and. 1<=jend)print*,'PVTH at N POLE= ' & - ,pvth(1,1,lp),pvth(im/2,1,lp) & - ,pvth(10,10,lp),pvth(im/2,10,lp),SPVAL,grib,LP + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & + ! ,SPVAL,PVTH(1:IM,JSTA:JEND,LP)) + ! IF(1>=jsta .and. 1<=jend)print*,'PVTH at N POLE= ' & + ! ,pvth(1,1,lp),pvth(im/2,1,lp) & + ! ,pvth(10,10,lp),pvth(im/2,10,lp),SPVAL,grib,LP + DUM2D(ISTA:IEND,JSTA:JEND)=PVTH(ISTA:IEND,JSTA:JEND,LP) + CALL EXCH(DUM2D) + CALL FULLPOLE(DUM2D,PVPOLES) + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + PVTEMP=SPVAL + IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1) + IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,PVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) PVTH(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1) + IF(JEND==JM) PVTH(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM) + !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(PVTH(I,J,LP) /= SPVAL)THEN GRID1(I,J) = PVTH(I,J,LP)*1.0E-6 ELSE @@ -773,11 +799,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(335)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(335)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -790,7 +817,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(353)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HMTH(I,J,LP) ENDDO ENDDO @@ -798,11 +825,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(353)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(353)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -815,7 +843,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(351)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SIGMATH(I,J,LP) ENDDO ENDDO @@ -823,11 +851,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(351)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(351)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -840,7 +869,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(352)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RHTH(I,J,LP) /= SPVAL) THEN GRID1(I,J) = 100.0 * MIN(1.,MAX(RHmin,RHTH(I,J,LP))) ELSE @@ -852,11 +881,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(352)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(352)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -869,7 +899,7 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(LVLS(LP,IGET(378)) > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = OTH(I,J,LP) ENDDO ENDDO @@ -877,11 +907,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(378)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(378)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -895,11 +926,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(IGET(336) > 0.OR.IGET(337) > 0)THEN IF(LVLS(LP,IGET(336)) > 0.OR.LVLS(LP,IGET(337)) > 0)THEN ! GFS use lon avg as one scaler value for pole point - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & - ,SPVAL,VPV(1:IM,JSTA:JEND,LP)) + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & + ! ,SPVAL,VPV(1:IM,JSTA:JEND,LP)) + DUM2D(ISTA:IEND,JSTA:JEND)=VPV(ISTA:IEND,JSTA:JEND,LP) + CALL EXCH(DUM2D) + CALL FULLPOLE(DUM2D,PVPOLES) + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + PVTEMP=SPVAL + IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1) + IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,PVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) VPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1) + IF(JEND==JM) VPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM) + !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UPV(I,J,LP) GRID2(I,J) = VPV(I,J,LP) ENDDO @@ -908,21 +955,23 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(336)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(336)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(337)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(337)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -935,11 +984,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(IGET(338) > 0)THEN IF(LVLS(LP,IGET(338)) > 0)THEN ! GFS use lon avg as one scaler value for pole point - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & - ,SPVAL,TPV(1:IM,JSTA:JEND,LP)) + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & + ! ,SPVAL,TPV(1:IM,JSTA:JEND,LP)) + DUM2D(ISTA:IEND,JSTA:JEND)=TPV(ISTA:IEND,JSTA:JEND,LP) + CALL EXCH(DUM2D) + CALL FULLPOLE(DUM2D,PVPOLES) + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + PVTEMP=SPVAL + IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1) + IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,PVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) TPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1) + IF(JEND==JM) TPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM) + !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TPV(I,J,LP) ENDDO ENDDO @@ -947,11 +1012,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(338)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(338)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -963,11 +1029,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(IGET(339) > 0) THEN IF(LVLS(LP,IGET(339)) > 0)THEN ! GFS use lon avg as one scaler value for pole point - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & - ,SPVAL,HPV(1:IM,JSTA:JEND,LP)) + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & + ! ,SPVAL,HPV(1:IM,JSTA:JEND,LP)) + DUM2D(ISTA:IEND,JSTA:JEND)=HPV(ISTA:IEND,JSTA:JEND,LP) + CALL EXCH(DUM2D) + CALL FULLPOLE(DUM2D,PVPOLES) + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + PVTEMP=SPVAL + IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1) + IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,PVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) HPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1) + IF(JEND==JM) HPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM) + !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HPV(I,J,LP) ENDDO ENDDO @@ -975,11 +1057,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(339)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(339)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -991,11 +1074,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(IGET(340) > 0) THEN IF(LVLS(LP,IGET(340)) > 0)THEN ! GFS use lon avg as one scaler value for pole point - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & - ,SPVAL,PPV(1:IM,JSTA:JEND,LP)) + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & + ! ,SPVAL,PPV(1:IM,JSTA:JEND,LP)) + DUM2D(ISTA:IEND,JSTA:JEND)=PPV(ISTA:IEND,JSTA:JEND,LP) + CALL EXCH(DUM2D) + CALL FULLPOLE(DUM2D,PVPOLES) + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + PVTEMP=SPVAL + IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1) + IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,PVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) PPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1) + IF(JEND==JM) PPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM) + !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PPV(I,J,LP) ENDDO ENDDO @@ -1003,11 +1102,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(340)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(340)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1019,11 +1119,27 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) IF(IGET(341) > 0) THEN IF(LVLS(LP,IGET(341)) > 0)THEN ! GFS use lon avg as one scaler value for pole point - call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & - ,SPVAL,SPV(1:IM,JSTA:JEND,LP)) + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1:IM,JSTA:JEND) & + ! ,SPVAL,SPV(1:IM,JSTA:JEND,LP)) + DUM2D(ISTA:IEND,JSTA:JEND)=SPV(ISTA:IEND,JSTA:JEND,LP) + CALL EXCH(DUM2D) + CALL FULLPOLE(DUM2D,PVPOLES) + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + PVTEMP=SPVAL + IF(JSTA== 1) PVTEMP(1:IM, 1)=PVPOLES(1:IM,1) + IF(JEND==JM) PVTEMP(1:IM,JM)=PVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,PVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) SPV(ISTA:IEND, 1,LP)=PVTEMP(ISTA:IEND, 1) + IF(JEND==JM) SPV(ISTA:IEND,JM,LP)=PVTEMP(ISTA:IEND,JM) + !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SPV(I,J,LP) ENDDO ENDDO @@ -1031,11 +1147,12 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(341)) fld_info(cfld)%lvl=LVLSXML(lp,IGET(341)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1046,10 +1163,10 @@ SUBROUTINE MDL2THANDPV(kth,kpv,th,pv) DEALLOCATE(DUM1D1,DUM1D2,DUM1D3,DUM1D4,DUM1D5,DUM1D6,DUM1D7, & DUM1D8,DUM1D9,DUM1D10,DUM1D11,DUM1D12,DUM1D13, & - DUM1D14,wrk1, wrk2, wrk3, wrk4, cosl) + DUM1D14,wrk1, wrk2, wrk3, wrk4, cosl, dum2d) END IF ! end of selection for isentropic and constant PV fields - if(me==0)print *,'end of MDL2THandpv' + if(me==0) write(0,*) 'MDL2THANDPV ends' ! ! ! END OF ROUTINE. diff --git a/sorc/ncep_post.fd/MDLFLD.f b/sorc/ncep_post.fd/MDLFLD.f index e1beeefc3..b3dbe03f3 100644 --- a/sorc/ncep_post.fd/MDLFLD.f +++ b/sorc/ncep_post.fd/MDLFLD.f @@ -43,6 +43,7 @@ !! 20-11-10 J MENG - USE UPP_MATH MODULE !! 20-11-10 J MENG - USE UPP_PHYSICS MODULE !! 21-04-01 J MENG - COMPUTATION ON DEFINED POINTS ONLY +!! 21-07-07 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MDLFLD !! INPUT ARGUMENT LIST: @@ -97,10 +98,11 @@ SUBROUTINE MDLFLD tops, dsnow, drain,const_ng1, const_ng2, gon, topg, dgraupel use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, grib, cfld, datapd,& fld_info, modelname, imp_physics, dtq2, spval, icount_calmict,& - me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm, aqfcmaq_on + me, dt, avrain, theat, ifhr, ifmin, avcnvc, lp1, im, jm, & + ista, iend, ista_2l, iend_2u, aqfcmaq_on use rqstfld_mod, only: iget, id, lvls, iavblfld, lvlsxml use gridspec_mod, only: gridtype,maptype,dxval - use upp_physics, only: CALRH, CALCAPE + use upp_physics, only: CALRH, CALCAPE, CALVOR use upp_math, only: H2U, H2V, U2H, V2H ! @@ -120,7 +122,7 @@ SUBROUTINE MDLFLD REAL CC(10), PPT(10) DATA CC / 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0 / DATA PPT/ 0., .14, .31, .70, 1.6, 3.4, 7.7, 17., 38., 85. / - INTEGER, dimension(im,jsta_2l:jend_2u) :: ICBOT, ICTOP, LPBL + INTEGER, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: ICBOT, ICTOP, LPBL ! ! DECLARE VARIABLES. @@ -129,7 +131,7 @@ SUBROUTINE MDLFLD LOGICAL NMM_GFSmicro LOGiCAL Model_Radar real, dimension(im,jm) :: GRID1, GRID2 - real, dimension(im,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& + real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: EGRID1, EGRID2, EGRID3, EGRID4, EGRID5,& EL0, P1D, T1D, Q1D, C1D, & FI1D, FR1D, FS1D, QW1, QI1, & QR1, QS1, CUREFL_S, & @@ -160,8 +162,8 @@ SUBROUTINE MDLFLD integer ks,nsmooth REAL SDUMMY(IM,2),dxm ! added to calculate cape and cin for icing - real, dimension(im,jsta:jend) :: dummy, cape, cin - integer idummy(IM,jsta:jend) + real, dimension(ista:iend,jsta:jend) :: dummy, cape, cin + integer idummy(ista:iend,jsta:jend) real, PARAMETER :: ZSL=0.0, TAUCR=RD*GI*290.66, CONST=0.005*G/RD, GORD=G/RD logical, parameter :: debugprint = .false. @@ -186,7 +188,7 @@ SUBROUTINE MDLFLD ! IF (ABS(MAXVAL(REF_10CM)-SPVAL)>SMALL)Model_Radar=.True. check_ref: DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(ABS(REF_10CM(I,J,L)-SPVAL)>SMALL) THEN Model_Radar=.True. exit check_ref @@ -196,9 +198,9 @@ SUBROUTINE MDLFLD ENDDO check_ref if(debugprint .and. me==0)print*,'Did post read in model derived radar ref ',Model_Radar, & 'MODELNAME=',trim(MODELNAME),' imp_physics=',imp_physics - ALLOCATE(EL (IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE(RICHNO (IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE(PBLRI (IM,JSTA_2L:JEND_2U)) + ALLOCATE(EL (ista_2l:iend_2u,JSTA_2L:JEND_2U,LM)) + ALLOCATE(RICHNO (ista_2l:iend_2u,JSTA_2L:JEND_2U,LM)) + ALLOCATE(PBLRI (ista_2l:iend_2u,JSTA_2L:JEND_2U)) ! ! SECOND, STANDARD NGM SEA LEVEL PRESSURE. IF (IGET(105) > 0 .OR. IGET(445) > 0) THEN @@ -207,18 +209,19 @@ SUBROUTINE MDLFLD IF (IGET(105) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = SLP(I,J) ENDDO ENDDO if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(105)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -233,7 +236,7 @@ SUBROUTINE MDLFLD ! print*,'DTQ2 in MDLFLD= ',DTQ2 RDTPHS=24.*3.6E6/DTQ2 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF ((HBOT(I,J)-HTOP(I,J)) <= 1.0) THEN ICBOT(I,J)=0 ICTOP(I,J)=0 @@ -261,7 +264,7 @@ SUBROUTINE MDLFLD ! CNVCFR(I,J)=100.*CFRdum CNVCFR(I,J)=CFRdum ENDIF !--- End IF (HBOT(I,J)-HTOP(I,J) <= 1.0) ... - ENDDO !--- DO I=1,IM + ENDDO !--- DO I=ista,iend ENDDO !--- DO J=JSTA,JEND ENDIF !-- IF (MODELNAME=='NMM' .OR. imp_physics==5) THEN ! @@ -279,7 +282,7 @@ SUBROUTINE MDLFLD .or. NMM_GFSmicro)THEN RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend CUPRATE=RDTPHS*CPRATE(I,J) !--- Cu precip rate, R (mm/h) ! CUPRATE=CUPPT(I,J)*1000./TRDLW !--- mm/h Zfrz(I,J)=ZMID(I,J,NINT(LMH(I,J))) !-- Initialize to lowest model level @@ -315,7 +318,7 @@ SUBROUTINE MDLFLD if(icount_calmict==0)then !only call calmict once in multiple grid processing DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend P1D(I,J)=PMID(I,J,L) T1D(I,J)=T(I,J,L) Q1D(I,J)=Q(I,J,L) @@ -368,7 +371,7 @@ SUBROUTINE MDLFLD refl_miss: IF (Model_Radar) THEN ! - Model output DBZ is present - proceed with calc DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(P1D(I,J) LLMH) THEN QQW(I,J,L) = D00 @@ -495,7 +498,7 @@ SUBROUTINE MDLFLD ELSE IF(MODELNAME == 'NMM' .and. GRIDTYPE=='B' .and. imp_physics==99)THEN !NMMB+Zhao DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L) = D00 @@ -523,7 +526,7 @@ SUBROUTINE MDLFLD ELSE IF(MODELNAME == 'NMM' .and. GRIDTYPE=='B' .and. imp_physics==6)THEN !NMMB+WSM6 DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend LLMH = NINT(LMH(I,J)) IF (L > LLMH) THEN QQW(I,J,L)=D00 @@ -562,7 +565,7 @@ SUBROUTINE MDLFLD .and. imp_physics==8)THEN !NMMB or FV3R +THOMPSON DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend DBZ(I,J,L)=REF_10CM(I,J,L) ENDDO ENDDO @@ -570,7 +573,7 @@ SUBROUTINE MDLFLD ELSE IF(imp_physics==99 .or. imp_physics==98)THEN ! Zhao MP DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend DBZ(I,J,L)=SPVAL ENDDO ENDDO @@ -588,7 +591,7 @@ SUBROUTINE MDLFLD ! Chuang: add convective contribution for all MP schemes RDTPHS=3.6E6/DTQ2 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend CUPRATE=RDTPHS*CPRATE(I,J) !--- Cu precip rate, R (mm/h) Zfrz(I,J)=ZMID(I,J,NINT(LMH(I,J))) !-- Initialize to lowest model level DO L=1,NINT(LMH(I,J)) !-- Start from the top, work down @@ -620,7 +623,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,l,curefl,fctr,dens,llmh,lctop,delz,ze_nc) DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend !--- Estimate radar reflectivity factor from convection at level L ! CUREFL(I,J)=0. @@ -737,7 +740,7 @@ SUBROUTINE MDLFLD ze_gmax = -1.E30 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend refl(i,j) = -10. ze_max = -10. @@ -885,7 +888,7 @@ SUBROUTINE MDLFLD ! ABSOLUTE VORTICITY ON MDL SURFACES. ! ! - allocate (RH3D(im,jsta_2l:jend_2u,lm)) + allocate (RH3D(ista_2l:iend_2u,jsta_2l:jend_2u,lm)) IF ( (IGET(001)>0).OR.(IGET(077)>0).OR. & (IGET(002)>0).OR.(IGET(003)>0).OR. & (IGET(004)>0).OR.(IGET(005)>0).OR. & @@ -921,7 +924,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = PMID(I,J,LL) ENDDO ENDDO @@ -929,11 +932,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(001)) fld_info(cfld)%lvl=LVLSXML(L,IGET(001)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -948,7 +952,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = QQW(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -957,11 +961,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(124)) fld_info(cfld)%lvl=LVLSXML(L,IGET(124)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -973,9 +978,9 @@ SUBROUTINE MDLFLD IF (IGET(125) > 0) THEN IF (LVLS(L,IGET(125)) > 0) THEN LL=LM-L+1 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = QQI(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -984,11 +989,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(125)) fld_info(cfld)%lvl=LVLSXML(L,IGET(125)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1002,7 +1008,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = QQR(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -1011,11 +1017,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(181)) fld_info(cfld)%lvl=LVLSXML(L,IGET(181)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1029,7 +1036,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = QQS(I,J,LL) if(GRID1(I,J)<1e-20) GRID1(I,J) = 0.0 ENDDO @@ -1038,11 +1045,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(182)) fld_info(cfld)%lvl=LVLSXML(L,IGET(182)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1056,7 +1064,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(QQG(I,J,LL) < 1.e-12) QQG(I,J,LL) = 0. !tgs GRID1(I,J) = QQG(I,J,LL) ENDDO @@ -1065,11 +1073,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(415)) fld_info(cfld)%lvl=LVLSXML(L,IGET(415)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1083,7 +1092,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(QQNW(I,J,LL) < 1.e-8) QQNW(I,J,LL) = 0. !tgs GRID1(I,J) = QQNW(I,J,LL) ENDDO @@ -1092,11 +1101,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(747)) fld_info(cfld)%lvl=LVLSXML(L,IGET(747)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1110,7 +1120,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(QQNI(I,J,LL) < 1.e-8) QQNI(I,J,LL) = 0. !tgs GRID1(I,J) = QQNI(I,J,LL) ENDDO @@ -1119,11 +1129,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(752)) fld_info(cfld)%lvl=LVLSXML(L,IGET(752)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1137,7 +1148,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(QQNR(I,J,LL) < 1.e-8) QQNR(I,J,LL) = 0. !tgs GRID1(I,J) = QQNR(I,J,LL) ENDDO @@ -1146,11 +1157,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(754)) fld_info(cfld)%lvl=LVLSXML(L,IGET(754)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1162,7 +1174,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(766)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(QQNWFA(I,J,LL)<1.e-8)QQNWFA(I,J,LL)=0. !tgs GRID1(I,J)=QQNWFA(I,J,LL) ENDDO @@ -1171,7 +1183,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(766)) fld_info(cfld)%lvl=LVLSXML(L,IGET(766)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1182,7 +1194,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(767)) > 0)THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(QQNIFA(I,J,LL)<1.e-8)QQNIFA(I,J,LL)=0. !tgs GRID1(I,J)=QQNIFA(I,J,LL) ENDDO @@ -1191,7 +1203,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(767)) fld_info(cfld)%lvl=LVLSXML(L,IGET(767)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1203,7 +1215,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(abs(CFR(I,J,LL)-SPVAL) > SMALL) & & GRID1(I,J) = CFR(I,J,LL)*H100 ENDDO @@ -1213,11 +1225,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(145)) fld_info(cfld)%lvl=LVLSXML(L,IGET(145)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1231,7 +1244,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(MODELNAME == 'RAPR') THEN GRID1(I,J) = CFR(I,J,LL) ELSE @@ -1243,11 +1256,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(774)) fld_info(cfld)%lvl=LVLSXML(L,IGET(774)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1270,14 +1284,14 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = REF_10CM(I,J,LL) ENDDO ENDDO ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = DBZ(I,J,LL) ENDDO ENDDO @@ -1288,11 +1302,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(250)) fld_info(cfld)%lvl=LVLSXML(L,IGET(250)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1307,7 +1322,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = CWM(I,J,LL) ENDDO ENDDO @@ -1315,11 +1330,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(199)) fld_info(cfld)%lvl=LVLSXML(L,IGET(199)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1333,7 +1349,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = F_rain(I,J,LL) ENDDO ENDDO @@ -1341,11 +1357,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(185)) fld_info(cfld)%lvl=LVLSXML(L,IGET(185)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1359,7 +1376,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = F_ice(I,J,LL) ENDDO ENDDO @@ -1367,11 +1384,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(186)) fld_info(cfld)%lvl=LVLSXML(L,IGET(186)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1386,7 +1404,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = F_RimeF(I,J,LL) ENDDO ENDDO @@ -1394,11 +1412,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(187)) fld_info(cfld)%lvl=LVLSXML(L,IGET(187)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1412,7 +1431,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = ZMID(I,J,LL) ENDDO ENDDO @@ -1420,11 +1439,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(077)) fld_info(cfld)%lvl=LVLSXML(L,IGET(077)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1438,7 +1458,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = T(I,J,LL) ENDDO ENDDO @@ -1446,11 +1466,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(002)) fld_info(cfld)%lvl=LVLSXML(L,IGET(002)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1464,7 +1485,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(T(I,J,LL)0) THEN !HC IF (LVLS(L,IGET(124))>0) THEN !HC DO J=JSTA,JEND -!HC DO I=1,IM +!HC DO I=ista,iend !HC IF(CWM(I,J,L)<0..AND.CWM(I,J,L)>-1.E-10) !HC 1 CWM(I,J,L)=0. !HC GRID1(I,J)=CWM(I,J,L) !HC ENDDO !HC ENDDO !HC ID(1:25) = 0 -!HC CALL GRIBIT(IGET(124),L,GRID1,IM,JM) +!HC CALL GRIBIT(IGET(124),L,GRIDista,iend,JM) !HC ENDIF !HC ENDIF ! @@ -1943,12 +1978,12 @@ SUBROUTINE MDLFLD ! IF (IGET(125)>0) THEN ! IF (LVLS(L,IGET(125))>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ista,iend ! GRID1(I,J)=QICE(I,J,L) ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(125),L,GRID1,IM,JM) +! CALL GRIBIT(IGET(125),L,GRIDista,iend,JM) ! ENDIF ! ENDIF ! @@ -1958,12 +1993,12 @@ SUBROUTINE MDLFLD ! IF (IGET(145)>0) THEN ! IF (LVLS(L,IGET(145))>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ista,iend ! GRID1(I,J)=CFRC(I,J,L) ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(145),L,GRID1,IM,JM) +! CALL GRIBIT(IGET(145),L,GRIDista,iend,JM) ! ENDIF ! ENDIF ! @@ -1974,7 +2009,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = TTND(I,J,LL) ENDDO ENDDO @@ -1982,11 +2017,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(140)) fld_info(cfld)%lvl=LVLSXML(L,IGET(140)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2000,7 +2036,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = RSWTT(I,J,LL) ENDDO ENDDO @@ -2008,11 +2044,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(040)) fld_info(cfld)%lvl=LVLSXML(L,IGET(040)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2026,7 +2063,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = RLWTT(I,J,LL) ENDDO ENDDO @@ -2034,11 +2071,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(041)) fld_info(cfld)%lvl=LVLSXML(L,IGET(041)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2057,9 +2095,9 @@ SUBROUTINE MDLFLD ELSE RRNUM=0. ENDIF -!$omp parallel do +!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(TRAIN(I,J,LL)ug/m3 ENDDO @@ -2234,11 +2276,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(995)) fld_info(cfld)%lvl=LVLSXML(L,IGET(995)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2257,7 +2300,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(PMID(I,J,LL)ug/m3 @@ -2299,11 +2343,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(629)) fld_info(cfld)%lvl=LVLSXML(L,IGET(629)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2316,7 +2361,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(DUST(I,J,LL,2)ug/m3 @@ -2329,11 +2374,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(630)) fld_info(cfld)%lvl=LVLSXML(L,IGET(630)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2346,7 +2392,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(DUST(I,J,LL,3)ug/m3 @@ -2359,11 +2405,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(631)) fld_info(cfld)%lvl=LVLSXML(L,IGET(631)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2376,7 +2423,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(DUST(I,J,LL,4)ug/m3 @@ -2389,11 +2436,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(632)) fld_info(cfld)%lvl=LVLSXML(L,IGET(632)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2406,7 +2454,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(DUST(I,J,LL,5)ug/m3 @@ -2419,11 +2467,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(633)) fld_info(cfld)%lvl=LVLSXML(L,IGET(633)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2436,7 +2485,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(SALT(I,J,LL,1)ug/m3 ELSE @@ -2448,11 +2497,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(634)) fld_info(cfld)%lvl=LVLSXML(L,IGET(634)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2465,7 +2515,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(SALT(I,J,LL,2)ug/m3 ELSE @@ -2477,11 +2527,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(635)) fld_info(cfld)%lvl=LVLSXML(L,IGET(635)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2494,7 +2545,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(SALT(I,J,LL,3)ug/m3 ELSE @@ -2506,11 +2557,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(636)) fld_info(cfld)%lvl=LVLSXML(L,IGET(636)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2523,7 +2575,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(SALT(I,J,LL,4)ug/m3 ELSE @@ -2535,11 +2587,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(637)) fld_info(cfld)%lvl=LVLSXML(L,IGET(637)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2552,7 +2605,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(SALT(I,J,LL,5)ug/m3 ELSE @@ -2564,11 +2617,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(638)) fld_info(cfld)%lvl=LVLSXML(L,IGET(638)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2581,7 +2635,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(SUSO(I,J,LL,1)ug/m3 @@ -2594,11 +2648,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(639)) fld_info(cfld)%lvl=LVLSXML(L,IGET(639)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2611,7 +2666,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(WASO(I,J,LL,1)0) THEN ! RDTPHS=1000./DTQ2 ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ista,iend ! GRID1(I,J)=CPRATE(I,J)*RDTPHS ! GRID1(I,J)=SPVAL ! ENDDO ! ENDDO ! ID(1:25) = 0 -! CALL GRIBIT(IGET(249),LM,GRID1,IM,JM) +! CALL GRIBIT(IGET(249),LM,GRIDista,iend,JM) ! ENDIF ! ! COMPOSITE RADAR REFLECTIVITY (maximum dBZ in each column) @@ -2853,7 +2914,7 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS /= 8 .and. IMP_PHYSICS /= 28) THEN !$omp parallel do private(i,j,l) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J) = MAX( GRID1(I,J), DBZ(I,J,L) ) @@ -2873,7 +2934,7 @@ SUBROUTINE MDLFLD MODELNAME=='NMM' .and. gridtype=='E')THEN !$omp parallel do private(i,j,l) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J) = MAX( GRID1(I,J), REF_10CM(I,J,L) ) @@ -2883,7 +2944,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = REFC_10CM(I,J) ENDDO ENDDO @@ -2892,7 +2953,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = refl(i,j) ENDDO ENDDO @@ -2902,11 +2963,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(252)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2917,7 +2979,7 @@ SUBROUTINE MDLFLD ! on emprical conversion factors (0.00344) IF (IGET(581)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) if(zint(i,j,l) < spval .and.zint(i,j,l+1)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZR(I,J,L) ) @@ -2954,11 +3017,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(276)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2969,7 +3033,7 @@ SUBROUTINE MDLFLD ! IF (IGET(277)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZI(I,J,L) ) @@ -2979,11 +3043,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(277)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2996,7 +3061,7 @@ SUBROUTINE MDLFLD ! IF (IGET(278)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=DBZmin DO L=1,NINT(LMH(I,J)) GRID1(I,J)=MAX( GRID1(I,J), DBZC(I,J,L) ) @@ -3006,11 +3071,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(278)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3022,7 +3088,7 @@ SUBROUTINE MDLFLD IF (IGET(426)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L)>=18.0) THEN @@ -3035,11 +3101,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(426)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3057,7 +3124,7 @@ SUBROUTINE MDLFLD IF (IGET(768) > 0) THEN IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L)>=18.0) THEN @@ -3086,7 +3153,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = -999. DO L=1,NINT(LMH(I,J)) IF (DBZ(I,J,L) >= 18.0) THEN @@ -3100,11 +3167,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(768)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3114,7 +3182,7 @@ SUBROUTINE MDLFLD ! IF (IGET(769)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=0.0 DO L=1,NINT(LMH(I,J)) IF(QQR(I,J,L) 0) THEN IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) IF (REF_10CM(I,J,L) > -10.0 ) THEN @@ -3163,7 +3232,7 @@ SUBROUTINE MDLFLD ENDDO ELSE DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = 0.0 DO L=1,NINT(LMH(I,J)) GRID1(I,J) = GRID1(I,J) + 0.00344 * & @@ -3176,11 +3245,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(770)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3196,7 +3266,7 @@ SUBROUTINE MDLFLD !--- Needed values at 1st level above ground (Jin, '01; Ferrier, Feb '02) ! DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend LLMH=NINT(LMH(I,J)) Q1D(I,J)=Q(I,J,LLMH) if(Q1D(I,J)<=0.) Q1D(I,J)=0. !tgs @@ -3264,7 +3334,7 @@ SUBROUTINE MDLFLD ! !-- Visibility using Warner-Stoelinga algorithm (Jin, '01) ! - ii=im/2 + ii=(ista+iend)/2 jj=(jsta+jend)/2 ! print*,'Debug: Visbility ',Q1D(ii,jj),QW1(ii,jj),QR1(ii,jj) ! +,QI1(ii,jj) ,QS1(ii,jj),T1D(ii,jj),P1D(ii,jj) @@ -3276,7 +3346,7 @@ SUBROUTINE MDLFLD ! DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(vis(i,j)/=spval.and.abs(vis(i,j))>24135.1)print*,'bad visbility' & , i,j,Q1D(i,j),QW1(i,j),QR1(i,j),QI1(i,j) & , QS1(i,j),T1D(i,j),P1D(i,j),vis(i,j) @@ -3288,7 +3358,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(180)) fld_info(cfld)%lvl=LVLSXML(1,IGET(180)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3298,7 +3368,7 @@ SUBROUTINE MDLFLD IF (IGET(410)>0) THEN CALL CALVIS_GSD(CZEN,VIS) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=VIS(I,J) END DO END DO @@ -3306,7 +3376,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(410)) fld_info(cfld)%lvl=LVLSXML(1,IGET(410)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3321,7 +3391,7 @@ SUBROUTINE MDLFLD GRID1 = -20.0 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = REF1KM_10CM(I,J) END DO END DO @@ -3329,7 +3399,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = refl1km(I,J) END DO END DO @@ -3340,7 +3410,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(748)) fld_info(cfld)%lvl=LVLSXML(1,IGET(748)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3355,7 +3425,7 @@ SUBROUTINE MDLFLD IF(MODELNAME == 'RAPR' .AND. (IMP_PHYSICS == 8 .or. IMP_PHYSICS == 28)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = REF4KM_10CM(I,J) END DO END DO @@ -3363,7 +3433,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = refl4km(I,J) END DO END DO @@ -3374,7 +3444,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(757)) fld_info(cfld)%lvl=LVLSXML(1,IGET(757)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -3382,7 +3452,7 @@ SUBROUTINE MDLFLD IF (IGET(912)>0) THEN Zm10c=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend ! dong handle missing value if (slp(i,j) < spval) then Zm10c(I,J)=ZMID(I,J,NINT(LMH(I,J))) @@ -3406,7 +3476,7 @@ SUBROUTINE MDLFLD IF(IMP_PHYSICS==8 .or. IMP_PHYSICS==28) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3417,7 +3487,7 @@ SUBROUTINE MDLFLD ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=spval ! dong handle missing value if (slp(i,j) < spval) then @@ -3433,7 +3503,7 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(912)) fld_info(cfld)%lvl=LVLSXML(L,IGET(912)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3450,14 +3520,14 @@ SUBROUTINE MDLFLD IF (IGET(147)>0) THEN ! DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = EL0(I,J) ENDDO ENDDO if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(147)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -3470,7 +3540,7 @@ SUBROUTINE MDLFLD !$omp parallel do private(i,j,l) DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend EL(I,J,L) = D00 ENDDO ENDDO @@ -3481,7 +3551,7 @@ SUBROUTINE MDLFLD ELSE IF(MODELNAME == 'NMM')THEN DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend EL(I,J,L)=EL_PBL(I,J,L) !NOW EL COMES OUT OF WRF NMM ENDDO ENDDO @@ -3504,7 +3574,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = EL(I,J,LL) ENDDO ENDDO @@ -3512,11 +3582,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(146)) fld_info(cfld)%lvl=LVLSXML(L,IGET(146)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3531,7 +3602,7 @@ SUBROUTINE MDLFLD LL=LM-L+1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = RICHNO(I,J,LL) ENDDO ENDDO @@ -3539,11 +3610,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(111)) fld_info(cfld)%lvl=LVLSXML(L,IGET(111)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3575,7 +3647,7 @@ SUBROUTINE MDLFLD IF (IGET(289) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = PBLRI(I,J) ! PBLH(I,J) = PBLRI(I,J) ENDDO @@ -3583,11 +3655,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then Cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(289)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3600,7 +3673,7 @@ SUBROUTINE MDLFLD IF ( (IGET(389) > 0) .OR. (IGET(454) > 0) ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF(PBLRI(I,J) 0.)THEN GRID1(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3654,10 +3727,10 @@ SUBROUTINE MDLFLD END DO END DO ! compute v component now - CALL H2V(EGRID3(1:im,JSTA_2L:JEND_2U),EGRID4) + CALL H2V(EGRID3(ista_2l:iend_2u,JSTA_2L:JEND_2U),EGRID4) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend EGRID1(i,j) = 0. EGRID2(i,j) = 0. EGRID5(i,j) = 0. @@ -3666,12 +3739,12 @@ SUBROUTINE MDLFLD END DO END DO vert_loopv: DO L=LM,1,-1 - CALL H2V(ZMID(1:IM,JSTA_2L:JEND_2U,L), EGRID5) - CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L+1),EGRID6) - CALL H2V(PINT(1:IM,JSTA_2L:JEND_2U,L), EGRID7) + CALL H2V(ZMID(ista_2l:iend_2u,JSTA_2L:JEND_2U,L), EGRID5) + CALL H2V(PINT(ista_2l:iend_2u,JSTA_2L:JEND_2U,L+1),EGRID6) + CALL H2V(PINT(ista_2l:iend_2u,JSTA_2L:JEND_2U,L), EGRID7) HCOUNT=0 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if (EGRID4(I,J) 0.)THEN GRID2(I,J) = EGRID1(I,J)/EGRID2(I,J) ELSE @@ -3700,11 +3773,11 @@ SUBROUTINE MDLFLD END DO - CALL U2H(GRID1(1,JSTA_2L),EGRID1) - CALL V2H(GRID2(1,JSTA_2L),EGRID2) + CALL U2H(GRID1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),EGRID1) + CALL V2H(GRID2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),EGRID2) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend ! EGRID1 is transport wind speed ! prevent floating overflow if either component is undefined @@ -3726,20 +3799,22 @@ SUBROUTINE MDLFLD if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(389)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(390)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii=ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -3756,7 +3831,7 @@ SUBROUTINE MDLFLD ! write(0,*) 'IM is: ', IM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend IF (PBLRI(I,J) /= SPVAL .and. EGRID3(I,J)/=SPVAL) then GRID1(I,J) = EGRID3(I,J)*PBLRI(I,J) @@ -3776,11 +3851,12 @@ SUBROUTINE MDLFLD if(grib=='grib2') then Cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(454)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3805,7 +3881,7 @@ SUBROUTINE MDLFLD ! if(me==0)print *,'dxm=',dxm NSMOOTH = nint(5.*(13500./dxm)) do j = jsta_2l, jend_2u - do i = 1, im + do i = ista_2l, iend_2u GRID1(i,j)=PBLHGUST(i,j) enddo enddo @@ -3814,14 +3890,14 @@ SUBROUTINE MDLFLD CALL SMOOTH(GRID1,SDUMMY,IM,JM,0.5) end do do j = jsta_2l, jend_2u - do i = 1, im + do i = ista_2l, iend_2u PBLHGUST(i,j)=GRID1(i,j) enddo enddo ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend LPBL(I,J)=LM if(ZINT(I,J,NINT(LMH(I,J))+1) 0) THEN -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend ! if(GUST(I,J) > 200. .and. gust(i,j)0) THEN - allocate(PBLREGIME(im,jsta_2l:jend_2u)) + allocate(PBLREGIME(ista_2l:iend_2u,jsta_2l:jend_2u)) CALL CALPBLREGIME(PBLREGIME) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J) = PBLREGIME(I,J) ENDDO ENDDO if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(344)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3906,7 +3984,7 @@ SUBROUTINE MDLFLD ! IF(IGET(400)>0)THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend !Initialed as 'undetected'. Nov. 17, 2014, B. ZHOU: !changed from SPVAL to -5000. to distinguish missing grids and undetected ! GRID1(I,J) = SPVAL @@ -3934,11 +4012,12 @@ SUBROUTINE MDLFLD if(grib=="grib2") then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(400)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3947,7 +4026,7 @@ SUBROUTINE MDLFLD ! ! COMPUTE NCAR GTG turbulence IF(IGET(464)>0 .or. IGET(467)>0 .or. IGET(470)>0)THEN - i=IM/2 + i=(ista+iend)/2 j=(jsta+jend)/2 ! if(me == 0) print*,'sending input to GTG i,j,hgt,gust',i,j,ZINT(i,j,LP1),gust(i,j) @@ -3957,10 +4036,10 @@ SUBROUTINE MDLFLD call gtg_algo(im,jm,lm,jsta,jend,jsta_2L,jend_2U,& uh,vh,wh,zmid,pmid,t,q,qqw,qqr,qqs,qqg,qqi,& - ZINT(1:IM,JSTA_2L:JEND_2U,LP1),pblh,sfcshx,sfclhx,ustar,& + ZINT(ista_2l:iend_2u,JSTA_2L:JEND_2U,LP1),pblh,sfcshx,sfclhx,ustar,& z0,gdlat,gdlon,dx,dy,u10,v10,GUST,avgprec,sm,sice,catedr,mwt,EL,gtg,RICHNO,item) - i=IM/2 + i=iend j=jend ! 321,541 ! print*,'GTG output: l,cat,mwt,gtg at',i,j ! do l=1,lm @@ -3973,7 +4052,7 @@ SUBROUTINE MDLFLD IF (LVLS(L,IGET(470))>0) THEN LL=LM-L+1 DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=gtg(i,j,LL) ENDDO ENDDO @@ -3981,18 +4060,19 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(470)) fld_info(cfld)%lvl=LVLSXML(L,IGET(470)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=catedr(i,j,LL) ENDDO ENDDO @@ -4000,17 +4080,18 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(471)) fld_info(cfld)%lvl=LVLSXML(L,IGET(471)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend GRID1(I,J)=mwt(i,j,LL) ENDDO ENDDO @@ -4018,11 +4099,12 @@ SUBROUTINE MDLFLD cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(472)) fld_info(cfld)%lvl=LVLSXML(L,IGET(472)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4045,7 +4127,7 @@ SUBROUTINE MDLFLD icing_gfip = spval icing_gfis = spval DO J=JSTA,JEND - DO I=1,IM + DO I=ista,iend if(debugprint .and. i==50 .and. j==jsta .and. me == 0) then print*,'sending input to FIP ',i,j,lm,gdlat(i,j),gdlon(i,j), & zint(i,j,lp1),cprate(i,j),prec(i,j),avgcprate(i,j),cape(i,j),cin(i,j) @@ -4079,12 +4161,12 @@ SUBROUTINE MDLFLD ! do l=1,lm ! if(LVLS(L,IGET(450))>0 .or. LVLS(L,IGET(480))>0)then ! do j=jsta,jend -! do i=1,im +! do i=ista,iend ! grid1(i,j)=icing_gfip(i,j,l) ! end do ! end do ! ID(1:25) = 0 -! CALL GRIBIT(IGET(450),L,GRID1,IM,JM) +! CALL GRIBIT(IGET(450),L,GRIDista,iend,JM) ! end if ! end do ENDIF diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f index 3bb9d9a96..9f23319e2 100644 --- a/sorc/ncep_post.fd/MISCLN.f +++ b/sorc/ncep_post.fd/MISCLN.f @@ -48,6 +48,7 @@ !! 21-09-01 E Colon - Correction to the effective layer top and !! bottoma calculation which is only employed !! for RTMA usage. +!! 21-10-14 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL MISCLN !! INPUT ARGUMENT LIST: @@ -95,7 +96,8 @@ SUBROUTINE MISCLN rhmin, rgamog, tfrz, small, g use ctlblk_mod, only: grib, cfld, fld_info, datapd, im, jsta, jend, jm, jsta_m, jend_m, & nbnd, nbin_du, lm, htfd, spval, pthresh, nfd, petabnd, me,& - jsta_2l, jend_2u, MODELNAME, SUBMODELNAME + jsta_2l, jend_2u, MODELNAME, SUBMODELNAME, & + ista, iend, ista_m, iend_M, ista_2l, iend_2u use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml use grib2_module, only: pset use upp_physics, only: FPVSNEW,CALRH_PW,CALCAPE,CALCAPE2,TVIRTUAL @@ -123,18 +125,18 @@ SUBROUTINE MISCLN ! DECLARE VARIABLES. ! LOGICAL NORTH, FIELD1,FIELD2 - LOGICAL, dimension(IM,JSTA:JEND) :: DONE, DONE1 + LOGICAL, dimension(ISTA:IEND,JSTA:JEND) :: DONE, DONE1 INTEGER, allocatable :: LVLBND(:,:,:),LB2(:,:) ! INTEGER LVLBND(IM,JM,NBND),LB2(IM,JM),LPBL(IM,JM) real,dimension(im,jm) :: GRID1, GRID2 - real,dimension(im,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, & + real,dimension(ista:iend,jsta:jend) :: P1D, T1D, Q1D, U1D, V1D, SHR1D, Z1D, & RH1D, EGRID1, EGRID2, EGRID3, EGRID4, & EGRID5, EGRID6, EGRID7, EGRID8, & MLCAPE,MLCIN,MLLCL,MUCAPE,MUCIN,MUMIXR, & FREEZELVL,MUQ1D,SLCL,THE,MAXTHE - integer,dimension(im,jsta:jend) :: MAXTHEPOS + integer,dimension(ista:iend,jsta:jend) :: MAXTHEPOS real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, & PBND, TBND, QBND, & UBND, VBND, RHBND, & @@ -159,7 +161,7 @@ SUBROUTINE MISCLN EFFUST,EFFVST,FSHR,HTSFC,& ESRH ! - integer I,J,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), & + integer I,J,ii,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), & iget1, iget2, iget3, LLMH,imax,jmax,lmax real DPBND,PKL1,PKU1,FAC1,FAC2,PL,TL,QL,QSAT,RHL,TVRL,TVRBLO, & ES1,ES2,QS1,QS2,RH1,RH2,ZSF,DEPTH(2),work1,work2,work3, & @@ -172,8 +174,8 @@ SUBROUTINE MISCLN integer, allocatable :: ITYPEFDLVLCTL(:) integer IE,IW,JN,JS,IVE(JM),IVW(JM),JVN,JVS integer ISTART,ISTOP,JSTART,JSTOP,MIDCAL - real dummy(IM,jsta:jend) - integer idummy(IM,jsta:jend) + real dummy(ista:iend,jsta:jend) + integer idummy(ista:iend,jsta:jend) ! NEW VARIABLES USED FOR EFFECTIVE LAYER INTEGER,dimension(:,:),allocatable :: EL_BASE, EL_TOPS LOGICAL,dimension(:,:),allocatable :: FOUND_BASE, FOUND_TOPS @@ -201,10 +203,10 @@ SUBROUTINE MISCLN debugprint = .FALSE. - allocate(USHR1(IM,jsta_2l:jend_2u),VSHR1(IM,jsta_2l:jend_2u), & - USHR6(IM,jsta_2l:jend_2u),VSHR6(IM,jsta_2l:jend_2u)) - allocate(UST(IM,jsta_2l:jend_2u),VST(IM,jsta_2l:jend_2u), & - HELI(IM,jsta_2l:jend_2u,2),FSHR(IM,jsta_2l:jend_2u)) + allocate(USHR1(ista_2l:iend_2u,jsta_2l:jend_2u),VSHR1(ista_2l:iend_2u,jsta_2l:jend_2u), & + USHR6(ista_2l:iend_2u,jsta_2l:jend_2u),VSHR6(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(UST(ista_2l:iend_2u,jsta_2l:jend_2u),VST(ista_2l:iend_2u,jsta_2l:jend_2u), & + HELI(ista_2l:iend_2u,jsta_2l:jend_2u,2),FSHR(ista_2l:iend_2u,jsta_2l:jend_2u)) ! ! HELICITY AND STORM MOTION. iget1 = IGET(162) @@ -221,7 +223,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HELI(I,J,1) ENDDO ENDDO @@ -229,11 +231,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(iget1) fld_info(cfld)%lvl=LVLSXML(1,iget1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -242,7 +245,7 @@ SUBROUTINE MISCLN IF (iget3 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HELI(I,J,2) ENDDO ENDDO @@ -250,11 +253,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(iget1) fld_info(cfld)%lvl=LVLSXML(2,iget1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -263,18 +267,19 @@ SUBROUTINE MISCLN IF (IGET(163) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UST(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(163)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -282,18 +287,19 @@ SUBROUTINE MISCLN IF (IGET(164) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = VST(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(164)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -303,15 +309,16 @@ SUBROUTINE MISCLN ! UPDRAFT HELICITY if (IGET(427) > 0) THEN - CALL CALUPDHEL(GRID1(1,jsta_2l)) + CALL CALUPDHEL(GRID1(ista_2l:iend_2u,jsta_2l:jend_2u)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(427)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -328,25 +335,26 @@ SUBROUTINE MISCLN ! 0-6 km shear magnitude !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND FSHR(I,J) = SQRT(USHR6(I,J)**2+VSHR6(I,J)**2) ENDDO ENDDO IF(IGET(430) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = USHR1(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(430)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -354,18 +362,19 @@ SUBROUTINE MISCLN IF(IGET(431) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = VSHR1(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(431)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -373,18 +382,19 @@ SUBROUTINE MISCLN IF(IGET(432) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = USHR6(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(432)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -392,18 +402,19 @@ SUBROUTINE MISCLN IF(IGET(433) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = VSHR6(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(433)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -429,7 +440,7 @@ SUBROUTINE MISCLN ! Chuang: Use GFS algorithm per Iredell's and DiMego's decision on unification !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(PMID(I,J,1) 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = P1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(054)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -475,16 +487,17 @@ SUBROUTINE MISCLN ! ICAO HEIGHT OF TROPOPAUSE IF (IGET(399)>0) THEN - CALL ICAOHEIGHT(P1D, GRID1(1,jsta)) + CALL ICAOHEIGHT(P1D, GRID1(ista:iend,jsta:jend)) ! print*,'sample TROPOPAUSE ICAO HEIGHTS',GRID1(im/2,(jsta+jend)/2) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(399)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -494,18 +507,19 @@ SUBROUTINE MISCLN IF (IGET(177) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Z1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(177)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -515,18 +529,19 @@ SUBROUTINE MISCLN IF (IGET(055) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = T1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(055)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -534,15 +549,16 @@ SUBROUTINE MISCLN ! ! TROPOPAUSE POTENTIAL TEMPERATURE. IF (IGET(108) > 0) THEN - CALL CALPOT(P1D,T1D,GRID1(1,jsta)) + CALL CALPOT(P1D,T1D,GRID1(ista:iend,jsta:jend)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(108)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -552,7 +568,7 @@ SUBROUTINE MISCLN IF ((IGET(056) > 0).OR.(IGET(057) > 0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=U1D(I,J) GRID2(I,J)=V1D(I,J) ENDDO @@ -561,22 +577,24 @@ SUBROUTINE MISCLN if(IGET(056)>0) then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(056)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif if(IGET(057)>0) then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(057)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -587,18 +605,19 @@ SUBROUTINE MISCLN IF (IGET(058) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SHR1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(058)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -612,11 +631,11 @@ SUBROUTINE MISCLN IF ((IGET(173)>0) .OR. (IGET(174)>0) .OR. & (IGET(175)>0) .OR. (IGET(176)>0)) THEN - allocate(MAXWP(IM,jsta:jend), MAXWZ(IM,jsta:jend), & - MAXWU(IM,jsta:jend), MAXWV(IM,jsta:jend),MAXWT(IM,jsta:jend)) + allocate(MAXWP(ista:iend,jsta:jend), MAXWZ(ista:iend,jsta:jend), & + MAXWU(ista:iend,jsta:jend), MAXWV(ista:iend,jsta:jend),MAXWT(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND MAXWP(I,J)=SPVAL MAXWZ(I,J)=SPVAL MAXWU(I,J)=SPVAL @@ -628,7 +647,7 @@ SUBROUTINE MISCLN ! Chuang: Use GFS algorithm per Iredell's and DiMego's decision on unification !$omp parallel do private(i,j) DO J=JSTA,JEND - loopI:DO I=1,IM + loopI:DO I=ISTA,IEND DO L=1,LM IF (ABS(PMID(I,J,L)-SPVAL)<=SMALL .OR. & ABS(UH(I,J,L)-SPVAL)<=SMALL .OR. & @@ -651,34 +670,36 @@ SUBROUTINE MISCLN IF (IGET(173) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = MAXWP(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(173)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ENDIF ! ICAO HEIGHT OF MAX WIND LEVEL IF (IGET(398)>0) THEN - CALL ICAOHEIGHT(MAXWP, GRID1(1,jsta)) + CALL ICAOHEIGHT(MAXWP, GRID1(ista:iend,jsta:jend)) ! print*,'sample MAX WIND ICAO HEIGHTS',GRID1(im/2,(jsta+jend)/2) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(398)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -687,18 +708,19 @@ SUBROUTINE MISCLN IF (IGET(174) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = MAXWZ(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(174)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -708,7 +730,7 @@ SUBROUTINE MISCLN IF ((IGET(175) > 0).OR.(IGET(176) > 0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = MAXWU(I,J) GRID2(I,J) = MAXWV(I,J) ENDDO @@ -716,20 +738,22 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(175)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(176)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -738,18 +762,19 @@ SUBROUTINE MISCLN IF (IGET(314) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=MAXWT(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(314)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -767,10 +792,10 @@ SUBROUTINE MISCLN (IGET(604)>0.or.IGET(605)>0).OR. & (IGET(451)>0.or.IGET(578)>0).OR.IGET(580)>0 ) THEN - ALLOCATE(T7D(IM,JSTA:JEND,NFD), Q7D(IM,JSTA:JEND,NFD), & - U7D(IM,JSTA:JEND,NFD), V6D(IM,JSTA:JEND,NFD), & - P7D(IM,JSTA:JEND,NFD), ICINGFD(IM,JSTA:JEND,NFD) & - ,AERFD(IM,JSTA:JEND,NFD,NBIN_DU)) + ALLOCATE(T7D(ISTA:IEND,JSTA:JEND,NFD), Q7D(ISTA:IEND,JSTA:JEND,NFD), & + U7D(ISTA:IEND,JSTA:JEND,NFD), V6D(ISTA:IEND,JSTA:JEND,NFD), & + P7D(ISTA:IEND,JSTA:JEND,NFD), ICINGFD(ISTA:IEND,JSTA:JEND,NFD),& + AERFD(ISTA:IEND,JSTA:JEND,NFD,NBIN_DU)) ! ! DETERMINE WHETHER TO DO MSL OR AGL FD LEVELS @@ -855,7 +880,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = T7D(I,J,IFD) ENDDO ENDDO @@ -864,11 +889,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET1) fld_info(cfld)%lvl = LVLSXML(IFD,IGET1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -878,11 +904,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET2) fld_info(cfld)%lvl = LVLSXML(IFD,IGET2) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -894,7 +921,7 @@ SUBROUTINE MISCLN IF (IGET(911)>0) THEN IF (LVLS(IFD,IGET(911))>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if ( T7D(I,J,IFD) > 600 ) then GRID1(I,J)=SPVAL else @@ -908,7 +935,7 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(911)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(911)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -932,7 +959,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Q7D(I,J,IFD) ENDDO ENDDO @@ -941,11 +968,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET1) fld_info(cfld)%lvl = LVLSXML(IFD,IGET1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -955,11 +983,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET2) fld_info(cfld)%lvl = LVLSXML(IFD,IGET2) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -984,7 +1013,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = P7D(I,J,IFD) ENDDO ENDDO @@ -993,11 +1022,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET1) fld_info(cfld)%lvl = LVLSXML(IFD,IGET1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1007,11 +1037,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET2) fld_info(cfld)%lvl = LVLSXML(IFD,IGET2) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1036,7 +1067,7 @@ SUBROUTINE MISCLN IF (work1 > 0 .or. work2 > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ICINGFD(I,J,IFD) ENDDO ENDDO @@ -1045,11 +1076,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET1) fld_info(cfld)%lvl = LVLSXML(IFD,IGET1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1059,11 +1091,12 @@ SUBROUTINE MISCLN cfld = cfld + 1 fld_info(cfld)%ifld = IAVBLFLD(IGET2) fld_info(cfld)%lvl = LVLSXML(IFD,IGET2) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1077,7 +1110,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(601))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AERFD(I,J,IFD,1) ENDDO ENDDO @@ -1086,11 +1119,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(601)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(601)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1102,7 +1136,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(602))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AERFD(I,J,IFD,2) ENDDO ENDDO @@ -1111,11 +1145,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(602)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(602)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1127,7 +1162,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(603))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AERFD(I,J,IFD,3) ENDDO ENDDO @@ -1136,11 +1171,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(603)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(603)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1152,7 +1188,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(604))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AERFD(I,J,IFD,4) ENDDO ENDDO @@ -1161,11 +1197,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(604)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(604)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1177,7 +1214,7 @@ SUBROUTINE MISCLN IF (LVLS(IFD,IGET(605))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AERFD(I,J,IFD,5) ENDDO ENDDO @@ -1186,11 +1223,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(605)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(605)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1204,7 +1242,7 @@ SUBROUTINE MISCLN IF ((IGET(060)>0).OR.(IGET(061)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=U7D(I,J,IFD) GRID2(I,J)=V6D(I,J,IFD) ENDDO @@ -1215,11 +1253,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(060)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(060)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1231,11 +1270,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(061)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(061)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -1247,7 +1287,7 @@ SUBROUTINE MISCLN IF ((IGET(576)>0).OR.(IGET(577)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = U7D(I,J,IFD) GRID2(I,J) = V6D(I,J,IFD) ENDDO @@ -1258,11 +1298,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(576)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(576)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1274,11 +1315,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(577)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(577)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -1306,14 +1348,14 @@ SUBROUTINE MISCLN allocate(HTFDCTL(NFDCTL)) HTFDCTL=pset%param(N)%level ! print *, "GTG 467 levels=",pset%param(N)%level - allocate(GTGFD(IM,JSTA:JEND,NFDCTL)) + allocate(GTGFD(ISTA:IEND,JSTA:JEND,NFDCTL)) call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,HTFDCTL,GTG,GTGFD) ! print *, "GTG 467 Done GTGFD=",me,GTGFD(IM/2,jend,1:NFDCTL) DO IFD = 1,NFDCTL IF (LVLS(IFD,IGET(467))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=GTGFD(I,J,IFD) ENDDO ENDDO @@ -1321,11 +1363,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(467)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(467)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1344,13 +1387,13 @@ SUBROUTINE MISCLN if(allocated(HTFDCTL)) deallocate(HTFDCTL) allocate(HTFDCTL(NFDCTL)) HTFDCTL=pset%param(N)%level - allocate(CATFD(IM,JSTA:JEND,NFDCTL)) + allocate(CATFD(ISTA:IEND,JSTA:JEND,NFDCTL)) call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,HTFDCTL,catedr,CATFD) DO IFD = 1,NFDCTL IF (LVLS(IFD,IGET(468))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=CATFD(I,J,IFD) ENDDO ENDDO @@ -1358,11 +1401,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(468)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(468)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1381,13 +1425,13 @@ SUBROUTINE MISCLN if(allocated(HTFDCTL)) deallocate(HTFDCTL) allocate(HTFDCTL(NFDCTL)) HTFDCTL=pset%param(N)%level - allocate(MWTFD(IM,JSTA:JEND,NFDCTL)) + allocate(MWTFD(ISTA:IEND,JSTA:JEND,NFDCTL)) call FDLVL_MASS(ITYPEFDLVLCTL,NFDCTL,HTFDCTL,MWT,MWTFD) DO IFD = 1,NFDCTL IF (LVLS(IFD,IGET(469))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=MWTFD(I,J,IFD) ENDDO ENDDO @@ -1395,11 +1439,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(469)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(469)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1426,7 +1471,7 @@ SUBROUTINE MISCLN IF (IGET(062)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=Z1D(I,J) IF (SUBMODELNAME == 'RTMA') THEN FREEZELVL(I,J)=GRID1(I,J) @@ -1437,11 +1482,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(062)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1451,20 +1497,21 @@ SUBROUTINE MISCLN IF (IGET(063)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH1D(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(063)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1474,18 +1521,19 @@ SUBROUTINE MISCLN IF (IGET(753)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = P1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(753)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1500,7 +1548,7 @@ SUBROUTINE MISCLN IF (IGET(165)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1508,11 +1556,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(165)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1523,7 +1572,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1531,11 +1580,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(350)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1545,18 +1595,19 @@ SUBROUTINE MISCLN IF (IGET(756)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = P1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(756)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1573,7 +1624,7 @@ SUBROUTINE MISCLN IF (IGET(776)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1581,11 +1632,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(776)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1596,7 +1648,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1604,11 +1656,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(777)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1618,18 +1671,19 @@ SUBROUTINE MISCLN IF (IGET(778)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=P1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(778)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1646,7 +1700,7 @@ SUBROUTINE MISCLN IF (IGET(779)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=Z1D(I,J) ENDDO ENDDO @@ -1654,11 +1708,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(779)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1669,7 +1724,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RH1D(I,J) < spval) GRID1(I,J)=RH1D(I,J)*100. ENDDO ENDDO @@ -1677,11 +1732,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(780)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1691,18 +1747,19 @@ SUBROUTINE MISCLN IF (IGET(781)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=P1D(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(781)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1710,10 +1767,10 @@ SUBROUTINE MISCLN ENDIF ! - allocate(PBND(IM,jsta:jend,NBND), TBND(IM,jsta:jend,NBND), & - QBND(IM,jsta:jend,NBND), UBND(IM,jsta:jend,NBND), & - VBND(IM,jsta:jend,NBND), RHBND(IM,jsta:jend,NBND), & - WBND(IM,jsta:jend,NBND)) + allocate(PBND(ista:iend,jsta:jend,NBND), TBND(ista:iend,jsta:jend,NBND), & + QBND(ista:iend,jsta:jend,NBND), UBND(ista:iend,jsta:jend,NBND), & + VBND(ista:iend,jsta:jend,NBND), RHBND(ista:iend,jsta:jend,NBND), & + WBND(ista:iend,jsta:jend,NBND)) ! ! ***BLOCK 5: BOUNDARY LAYER FIELDS. @@ -1733,9 +1790,9 @@ SUBROUTINE MISCLN (IGET(096)>0).OR.(IGET(097)>0).OR. & (IGET(098)>0).OR.(IGET(221)>0) ) THEN ! - allocate(OMGBND(IM,jsta:jend,NBND),PWTBND(IM,jsta:jend,NBND), & - QCNVBND(IM,jsta:jend,NBND),LVLBND(IM,jsta:jend,NBND), & - LB2(IM,jsta:jend)) + allocate(OMGBND(ista:iend,jsta:jend,NBND),PWTBND(ista:iend,jsta:jend,NBND), & + QCNVBND(ista:iend,jsta:jend,NBND),LVLBND(ista:iend,jsta:jend,NBND), & + LB2(ista:iend,jsta:jend)) ! COMPUTE ETA BOUNDARY LAYER FIELDS. CALL BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, & @@ -1743,7 +1800,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(i,j) = SPVAL ENDDO ENDDO @@ -1757,7 +1814,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(067))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PBND(I,J,LBND) ENDDO ENDDO @@ -1765,11 +1822,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(067)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(067)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1781,7 +1839,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(068))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=TBND(I,J,LBND) ENDDO ENDDO @@ -1789,11 +1847,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(068)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(068)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1803,16 +1862,17 @@ SUBROUTINE MISCLN ! BOUNDARY LAYER POTENTIAL TEMPERATURE. IF (IGET(069)>0) THEN IF (LVLS(LBND,IGET(069))>0) THEN - CALL CALPOT(PBND(1,jsta,LBND),TBND(1,jsta,LBND),GRID1(1,jsta)) + CALL CALPOT(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND),GRID1(ista:iend,jsta:jend)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(069)) fld_info(cfld)%lvl=LVLSXML(IFD,IGET(069)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1824,21 +1884,22 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(072))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=RHBND(I,J,LBND) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%lvl=LVLSXML(LBND,IGET(072)) fld_info(cfld)%ifld=IAVBLFLD(IGET(072)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1848,17 +1909,18 @@ SUBROUTINE MISCLN ! BOUNDARY LAYER DEWPOINT TEMPERATURE. IF (IGET(070)>0) THEN IF (LVLS(LBND,IGET(070))>0) THEN - CALL CALDWP(PBND(1,jsta,LBND), QBND(1,jsta,LBND), & - GRID1(1,jsta), TBND(1,jsta,LBND)) + CALL CALDWP(PBND(ista:iend,jsta:jend,LBND), QBND(ista:iend,jsta:jend,LBND), & + GRID1(ista:iend,jsta:jend), TBND(ista:iend,jsta:jend,LBND)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(070)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(070)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1870,7 +1932,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(071))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=QBND(I,J,LBND) ENDDO ENDDO @@ -1879,11 +1941,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(071)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(071)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1895,7 +1958,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(088))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QCNVBND(I,J,LBND) ENDDO ENDDO @@ -1903,11 +1966,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(088)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(088)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1929,7 +1993,7 @@ SUBROUTINE MISCLN IF(FIELD1.OR.FIELD2)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UBND(I,J,LBND) GRID2(I,J) = VBND(I,J,LBND) ENDDO @@ -1941,11 +2005,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(073)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(073)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1957,11 +2022,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(074)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(074)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -1974,7 +2040,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(090))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = OMGBND(I,J,LBND) ENDDO ENDDO @@ -1982,11 +2048,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(090)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(090)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endiF @@ -1998,7 +2065,7 @@ SUBROUTINE MISCLN IF (LVLS(LBND,IGET(089))>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PWTBND(I,J,LBND) ENDDO ENDDO @@ -2007,11 +2074,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(089)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(089)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2020,19 +2088,20 @@ SUBROUTINE MISCLN ! ! BOUNDARY LAYER LIFTED INDEX. IF (IGET(075)>0 .OR. IGET(031)>0 .OR. IGET(573)>0) THEN - CALL OTLFT(PBND(1,jsta,LBND),TBND(1,jsta,LBND), & - QBND(1,jsta,LBND),GRID1(1,jsta)) + CALL OTLFT(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND), & + QBND(ista,jsta,LBND),GRID1(ista:iend,jsta:jend)) IF(IGET(075)>0)THEN IF (LVLS(LBND,IGET(075))>0) THEN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(075)) fld_info(cfld)%lvl=LVLSXML(LBND,IGET(075)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2041,7 +2110,7 @@ SUBROUTINE MISCLN IF(IGET(031)>0 .or. IGET(573)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(I,J) = MIN(EGRID2(I,J),GRID1(I,J)) END DO END DO @@ -2073,7 +2142,7 @@ SUBROUTINE MISCLN ! 50 CONTINUE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=EGRID2(I,J) ENDDO ENDDO @@ -2083,7 +2152,7 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(031)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif endif @@ -2091,11 +2160,12 @@ SUBROUTINE MISCLN if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(573)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2132,18 +2202,18 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO ENDDO ! DO 80 LBND = 1,NBND - CALL CALTHTE(PBND(1,jsta,LBND),TBND(1,jsta,LBND), & - QBND(1,jsta,LBND),EGRID1) + CALL CALTHTE(PBND(ista,jsta,LBND),TBND(ista,jsta,LBND), & + QBND(ista,jsta,LBND),EGRID1) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (EGRID1(I,J) > EGRID2(I,J)) THEN EGRID2(I,J) = EGRID1(I,J) LB2(I,J) = LVLBND(I,J,LBND) @@ -2164,7 +2234,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -2173,11 +2243,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(566)) fld_info(cfld)%lvl=LVLSXML(1,IGET(566)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2188,7 +2259,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -2197,7 +2268,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -2206,11 +2277,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(567)) fld_info(cfld)%lvl=LVLSXML(1,IGET(567)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2222,18 +2294,19 @@ SUBROUTINE MISCLN IF(IGET(221) > 0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PBLH(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(221)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2242,24 +2315,25 @@ SUBROUTINE MISCLN ! EGRID1 IS LCL PRESSURE. EGRID2 IS LCL HEIGHT. ! IF ( (IGET(109)>0).OR.(IGET(110)>0) ) THEN - CALL CALLCL(PBND(1,jsta,1),TBND(1,jsta,1), & - QBND(1,jsta,1),EGRID1,EGRID2) + CALL CALLCL(PBND(ista,jsta,1),TBND(ista,jsta,1), & + QBND(ista,jsta,1),EGRID1,EGRID2) IF (IGET(109)>0) THEN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID2(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(109)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2268,18 +2342,19 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TBND(I,J,1) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(110)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2294,15 +2369,15 @@ SUBROUTINE MISCLN (IGET(096)>0).OR.(IGET(097)>0).OR. & (IGET(098)>0) ) THEN - allocate(T78483(im,jsta:jend), T89671(im,jsta:jend), & - P78483(im,jsta:jend), P89671(im,jsta:jend)) + allocate(T78483(ista:iend,jsta:jend), T89671(ista:iend,jsta:jend), & + P78483(ista:iend,jsta:jend), P89671(ista:iend,jsta:jend)) ! ! COMPUTE SIGMA 0.89671 AND 0.78483 TEMPERATURES ! INTERPOLATE LINEAR IN LOG P IF (IGET(097)>0.OR.IGET(098)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND P78483(I,J) = LOG(PINT(I,J,NINT(LMH(I,J)))*0.78483) P89671(I,J) = LOG(PINT(I,J,NINT(LMH(I,J)))*0.89671) ENDDO @@ -2312,7 +2387,7 @@ SUBROUTINE MISCLN !!$omp parallel do private(fac1,fac2,pkl1,pku1,t78483,t89671) DO L=2,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PKL1=0.5*(ALPINT(I,J,L)+ALPINT(I,J,L+1)) PKU1=0.5*(ALPINT(I,J,L)+ALPINT(I,J,L-1)) ! IF(I==1 .AND. J==1)PRINT*,'L,P89671,PKL1,PKU1= ', & @@ -2336,7 +2411,7 @@ SUBROUTINE MISCLN ! print*,'done(1,1)= ',done(1,1) !$omp parallel do private(i,j,pl,tl,ql,qsat,rhl) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(.NOT. DONE(I,J)) THEN PL = PINT(I,J,LM-1) TL = 0.5*(T(I,J,LM-2)+T(I,J,LM-1)) @@ -2406,7 +2481,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,LM) < spval) GRID1(I,J) = T89671(I,J) ! IF(T89671(I,J)>350.)PRINT*,'LARGE T89671 ', & ! I,J,T89671(I,J) @@ -2416,11 +2491,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(097)) fld_info(cfld)%lvl=LVLSXML(1,IGET(097)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2431,7 +2507,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,LM) < spval) GRID1(I,J) = T78483(I,J) ENDDO ENDDO @@ -2439,11 +2515,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(098)) fld_info(cfld)%lvl=LVLSXML(1,IGET(098)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2465,18 +2542,19 @@ SUBROUTINE MISCLN IF (IGET(091)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PBND(I,J,1) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(091)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2486,7 +2564,7 @@ SUBROUTINE MISCLN IF (IGET(092)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TBND(I,J,1) ENDDO ENDDO @@ -2494,11 +2572,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(092)) fld_info(cfld)%lvl=LVLSXML(1,IGET(092)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2508,7 +2587,7 @@ SUBROUTINE MISCLN IF (IGET(093)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QBND(I,J,1) ENDDO ENDDO @@ -2517,11 +2596,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(093)) fld_info(cfld)%lvl=LVLSXML(1,IGET(093)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2531,21 +2611,22 @@ SUBROUTINE MISCLN IF (IGET(094)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RHBND(I,J,1) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(094)) fld_info(cfld)%lvl=LVLSXML(1,IGET(094)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2555,7 +2636,7 @@ SUBROUTINE MISCLN IF ((IGET(095)>0).OR.(IGET(096)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = UBND(I,J,1) GRID2(I,J) = VBND(I,J,1) ENDDO @@ -2565,11 +2646,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(095)) fld_info(cfld)%lvl=LVLSXML(1,IGET(095)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2579,11 +2661,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(096)) fld_info(cfld)%lvl=LVLSXML(1,IGET(096)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -2609,29 +2692,30 @@ SUBROUTINE MISCLN ! IF ( (IGET(066)>0).OR.(IGET(081)>0).OR. & (IGET(082)>0).OR.(IGET(104)>0) ) THEN - allocate(RH3310(IM,jsta:jend),RH6610(IM,jsta:jend), & - RH3366(IM,jsta:jend),PW3310(IM,jsta:jend)) + allocate(RH3310(ista:iend,jsta:jend),RH6610(ista:iend,jsta:jend), & + RH3366(ista:iend,jsta:jend),PW3310(ista:iend,jsta:jend)) CALL LFMFLD(RH3310,RH6610,RH3366,PW3310) ! ! SIGMA 0.33-1.00 MEAN RELATIVE HUMIIDITY. IF (IGET(066)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH3310(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(066)) fld_info(cfld)%lvl=LVLSXML(1,IGET(066)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo ! print *,'in miscln,RH0.33-1.0,cfld=',cfld,'fld=', & @@ -2643,21 +2727,22 @@ SUBROUTINE MISCLN IF (IGET(081)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH6610(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(081)) fld_info(cfld)%lvl=LVLSXML(1,IGET(081)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2667,21 +2752,22 @@ SUBROUTINE MISCLN IF (IGET(082)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH3366(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(082)) fld_info(cfld)%lvl=LVLSXML(1,IGET(082)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2691,7 +2777,7 @@ SUBROUTINE MISCLN IF (IGET(104)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PW3310(I,J) ENDDO ENDDO @@ -2700,11 +2786,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(104)) fld_info(cfld)%lvl=LVLSXML(1,IGET(104)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2717,9 +2804,9 @@ SUBROUTINE MISCLN IF ( (IGET(099)>0).OR.(IGET(100)>0).OR. & (IGET(101)>0).OR.(IGET(102)>0).OR. & (IGET(103)>0) ) THEN - allocate(RH4710(IM,jsta_2l:jend_2u),RH4796(IM,jsta_2l:jend_2u), & - RH1847(IM,jsta_2l:jend_2u)) - allocate(RH8498(IM,jsta_2l:jend_2u),QM8510(IM,jsta_2l:jend_2u)) + allocate(RH4710(ista_2l:iend_2u,jsta_2l:jend_2u),RH4796(ista_2l:iend_2u,jsta_2l:jend_2u), & + RH1847(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(RH8498(ista_2l:iend_2u,jsta_2l:jend_2u),QM8510(ista_2l:iend_2u,jsta_2l:jend_2u)) CALL NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ! @@ -2727,21 +2814,22 @@ SUBROUTINE MISCLN IF (IGET(099)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH4710(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(099)) fld_info(cfld)%lvl=LVLSXML(1,IGET(099)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2751,21 +2839,22 @@ SUBROUTINE MISCLN IF (IGET(100)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH4796(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(100)) fld_info(cfld)%lvl=LVLSXML(1,IGET(100)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2775,21 +2864,22 @@ SUBROUTINE MISCLN IF (IGET(101)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH1847(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(101)) fld_info(cfld)%lvl=LVLSXML(1,IGET(101)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2799,21 +2889,22 @@ SUBROUTINE MISCLN IF (IGET(102)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RH8498(I,J) ENDDO ENDDO - CALL SCLFLD(GRID1,H100,IM,JM) + CALL SCLFLD(GRID1(ista:iend,jsta:jend),H100,IM,JM) CALL BOUND(GRID1,H1,H100) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(102)) fld_info(cfld)%lvl=LVLSXML(1,IGET(102)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2825,7 +2916,7 @@ SUBROUTINE MISCLN ! CONVERT TO DIVERGENCE FOR GRIB !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(QM8510(I,J) < spval) GRID1(I,J) = -1.0*QM8510(I,J) ENDDO ENDDO @@ -2833,11 +2924,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(103)) fld_info(cfld)%lvl=LVLSXML(1,IGET(103)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2849,8 +2941,8 @@ SUBROUTINE MISCLN IF ( (IGET(318)>0).OR.(IGET(319)>0).OR. & (IGET(320)>0))THEN - allocate(RH4410(IM,jsta:jend),RH7294(IM,jsta:jend), & - RH4472(IM,jsta:jend),RH3310(IM,jsta:jend)) + allocate(RH4410(ista:iend,jsta:jend),RH7294(ista:iend,jsta:jend), & + RH4472(ista:iend,jsta:jend),RH3310(ista:iend,jsta:jend)) CALL LFMFLD_GFS(RH4410,RH7294,RH4472,RH3310) ! ! SIGMA 0.44-1.00 MEAN RELATIVE HUMIIDITY. @@ -2858,7 +2950,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RH4410(I,J) < spval) GRID1(I,J) = RH4410(I,J)*100. ENDDO ENDDO @@ -2867,11 +2959,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(318)) fld_info(cfld)%lvl=LVLSXML(1,IGET(318)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2882,7 +2975,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RH7294(I,J) < spval) GRID1(I,J) = RH7294(I,J)*100. ENDDO ENDDO @@ -2891,11 +2984,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(319)) fld_info(cfld)%lvl=LVLSXML(1,IGET(319)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2906,7 +3000,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(RH4472(I,J) < spval) GRID1(I,J)=RH4472(I,J)*100. ENDDO ENDDO @@ -2915,11 +3009,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(320)) fld_info(cfld)%lvl=LVLSXML(1,IGET(320)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2933,7 +3028,7 @@ SUBROUTINE MISCLN (IGET(325)>0).OR.(IGET(326)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID2(I,J) = 0.995*PINT(I,J,LM+1) EGRID1(I,J) = LOG(PMID(I,J,LM)/EGRID2(I,J)) & / LOG(PMID(I,J,LM)/PMID(I,J,LM-1)) @@ -2954,7 +3049,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,LM)0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J)=EGRID2(I,J) IF (SUBMODELNAME == 'RTMA') MLLCL(I,J) = GRID1(I,J) ENDDO @@ -3267,7 +3370,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 ENDDO @@ -3281,7 +3384,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) THEN GRID1(I,J) = EGRID1(I,J) IF (SUBMODELNAME == 'RTMA') MUCAPE(I,J)=GRID1(I,J) @@ -3296,11 +3399,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(584)) fld_info(cfld)%lvl=LVLSXML(1,IGET(584)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3312,13 +3416,13 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO CALL BOUND(GRID1,D00,H99999) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) THEN GRID1(I,J) = - GRID1(I,J) IF (SUBMODELNAME == 'RTMA')THEN @@ -3332,11 +3436,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(585)) fld_info(cfld)%lvl=LVLSXML(1,IGET(585)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3348,7 +3453,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = EGRID4(I,J) ENDDO ENDDO @@ -3356,11 +3461,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(443)) fld_info(cfld)%lvl=LVLSXML(1,IGET(443)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3368,7 +3474,7 @@ SUBROUTINE MISCLN !Equilibrium Temperature IF (IGET(982)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TEQL(I,J) ENDDO ENDDO @@ -3376,11 +3482,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(982)) fld_info(cfld)%lvl=LVLSXML(1,IGET(982)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3393,7 +3500,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -3404,11 +3511,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(246)) fld_info(cfld)%lvl=LVLSXML(1,IGET(246)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3419,7 +3527,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CPRATE(I,J) < spval) THEN IF (CPRATE(I,J) > PTHRESH) THEN GRID1(I,J) = EGRID5(I,J) @@ -3434,11 +3542,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(444)) fld_info(cfld)%lvl=LVLSXML(1,IGET(444)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3451,13 +3560,13 @@ SUBROUTINE MISCLN ! --- Effective (inflow) Layer (EL) ! - ALLOCATE(EL_BASE(IM,JSTA_2L:JEND_2U)) - ALLOCATE(EL_TOPS(IM,JSTA_2L:JEND_2U)) - ALLOCATE(FOUND_BASE(IM,JSTA_2L:JEND_2U)) - ALLOCATE(FOUND_TOPS(IM,JSTA_2L:JEND_2U)) + ALLOCATE(EL_BASE(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) + ALLOCATE(EL_TOPS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) + ALLOCATE(FOUND_BASE(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) + ALLOCATE(FOUND_TOPS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EL_BASE(I,J) = LM EL_TOPS(I,J) = LM FOUND_BASE(I,J) = .FALSE. @@ -3475,7 +3584,7 @@ SUBROUTINE MISCLN ! SET AIR PARCELS FOR LEVEL L !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 IDUMMY(I,J) = 0 @@ -3494,7 +3603,7 @@ SUBROUTINE MISCLN !--- CHECK CAPE/CIN OF EACH AIR PARCELS WITH EL CRITERIA !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF ( .NOT. FOUND_BASE(I,J) ) THEN IF ( EGRID1(I,J) >= 100. .AND. EGRID2(I,J) >= -250. ) THEN EL_BASE(I,J) = L @@ -3539,7 +3648,7 @@ SUBROUTINE MISCLN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IREC = IREC + 1 IREC2 = IREC2 + 1 WRITE(IUNIT,'(1x,I6,2x,I6,2(2x,I6,2x,F12.3))') I, J, & @@ -3559,7 +3668,7 @@ SUBROUTINE MISCLN ! ! CAPE AND CINS 0-3KM, FOLLOW ML PROCEDURE WITH HEIGHT 0-3KM ! - IF (MODELNAME == 'RAPR') THEN + IF (MODELNAME == 'RAPR') THEN FIELD1=.FALSE. FIELD2=.FALSE. @@ -3580,7 +3689,8 @@ SUBROUTINE MISCLN ELSE !FV3R and others FIELD1=.TRUE. FIELD2=.TRUE. -! Wm Lewis 2 JUN 2022: Necessary that FIELD1/FIELD2=.FALSE. FOR GOES-16/17/18 +! Wm Lewis 2 JUN 2022: Necessary that FIELD1/FIELD2=.FALSE. FOR +! GOES-16/17/18 IF((IGET(927)>0).OR.(IGET(928)>0).OR.(IGET(929)>0).OR.(IGET(930)>0).OR. & (IGET(931)>0).OR.(IGET(932)>0).OR.(IGET(933)>0).OR.(IGET(934)>0).OR. & (IGET(935)>0).OR.(IGET(936)>0).OR.(IGET(937)>0).OR.(IGET(938)>0).OR. & @@ -3600,7 +3710,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 EGRID3(I,J) = -H99999 @@ -3634,7 +3744,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -3643,11 +3753,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(950)) fld_info(cfld)%lvl=LVLSXML(1,IGET(950)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3658,7 +3769,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = - EGRID2(I,J) ENDDO ENDDO @@ -3667,7 +3778,7 @@ SUBROUTINE MISCLN ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = - GRID1(I,J) ENDDO ENDDO @@ -3676,11 +3787,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(951)) fld_info(cfld)%lvl=LVLSXML(1,IGET(951)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3692,7 +3804,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -3701,11 +3813,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(952)) fld_info(cfld)%lvl=LVLSXML(1,IGET(952)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3714,10 +3827,10 @@ SUBROUTINE MISCLN ! EFFECTIVE STORM RELATIVE HELICITY AND STORM MOTION. - allocate(UST(IM,jsta_2l:jend_2u),VST(IM,jsta_2l:jend_2u), & - HELI(IM,jsta_2l:jend_2u,2)) - allocate(LLOW(IM,jsta_2l:jend_2u),LUPP(IM,jsta_2l:jend_2u), & - CANGLE(IM,jsta_2l:jend_2u)) + allocate(UST(ista_2l:iend_2u,jsta_2l:jend_2u),VST(ista_2l:iend_2u,jsta_2l:jend_2u), & + HELI(ista_2l:iend_2u,jsta_2l:jend_2u,2)) + allocate(LLOW(ista_2l:iend_2u,jsta_2l:jend_2u),LUPP(ista_2l:iend_2u,jsta_2l:jend_2u), & + CANGLE(ista_2l:iend_2u,jsta_2l:jend_2u)) iget1 = IGET(953) iget2 = -1 @@ -3735,7 +3848,7 @@ SUBROUTINE MISCLN !RELATED VARIABLES !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLOW(I,J) = EL_BASE(I,J) LUPP(I,J) = EL_TOPS(I,J) ENDDO @@ -3743,7 +3856,7 @@ SUBROUTINE MISCLN ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLOW(I,J) = INT(EGRID4(I,J)) LUPP(I,J) = INT(EGRID5(I,J)) ENDDO @@ -3760,7 +3873,7 @@ SUBROUTINE MISCLN IREC=0 OPEN(IUNIT,FILE=TRIM(ADJUSTL(EFFL_FNAME)),FORM='FORMATTED') DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IREC = IREC + 1 ! WRITE(IUNIT,'(1x,I6,2x,I6,2x,I6,2x,I6)')I,J,LLOW(I,J),LUPP(I,J) WRITE(IUNIT,'(1x,I6,2x,I6,2(2x,I6,2x,F12.3))') I, J, & @@ -3778,7 +3891,7 @@ SUBROUTINE MISCLN IF (iget2 > 0) then !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = HELI(I,J,1) ! GRID1(I,J) = HELI(I,J,2) ENDDO @@ -3787,11 +3900,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(iget1) fld_info(cfld)%lvl=LVLSXML(1,iget1) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3804,14 +3918,14 @@ SUBROUTINE MISCLN !EL field allocation - allocate(ESHR(IM,jsta_2l:jend_2u),UVECT(IM,jsta_2l:jend_2u),& - VVECT(IM,jsta_2l:jend_2u),HTSFC(IM,jsta_2l:jend_2u)) - allocate(EFFUST(IM,jsta_2l:jend_2u),EFFVST(IM,jsta_2l:jend_2u),& - ESRH(IM,jsta_2l:jend_2u)) + allocate(ESHR(ista_2l:iend_2u,jsta_2l:jend_2u),UVECT(ista_2l:iend_2u,jsta_2l:jend_2u),& + VVECT(ista_2l:iend_2u,jsta_2l:jend_2u),HTSFC(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(EFFUST(ista_2l:iend_2u,jsta_2l:jend_2u),EFFVST(ista_2l:iend_2u,jsta_2l:jend_2u),& + ESRH(ista_2l:iend_2u,jsta_2l:jend_2u)) ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND MAXTHE(I,J)=-H99999 THE(I,J)=-H99999 MAXTHEPOS(I,J)=0 @@ -3821,7 +3935,7 @@ SUBROUTINE MISCLN DO L=LM,1,-1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = -H99999 P1D(I,J)=PMID(I,J,L) T1D(I,J)=T(I,J,L) @@ -3830,7 +3944,7 @@ SUBROUTINE MISCLN ENDDO CALL CALTHTE(P1D,T1D,Q1D,EGRID1) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND THE(I,J)=EGRID1(I,J) IF(THE(I,J)>=MAXTHE(I,J))THEN MAXTHE(I,J)=THE(I,J) @@ -3851,8 +3965,8 @@ SUBROUTINE MISCLN IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -3862,8 +3976,8 @@ SUBROUTINE MISCLN IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -3873,13 +3987,13 @@ SUBROUTINE MISCLN IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) @@ -3898,7 +4012,7 @@ SUBROUTINE MISCLN IF (IGET(979)>0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ZINT(I,J,LLOW(I,J))0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ZINT(I,J,LUPP(I,J))0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LLOW(I,J)0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LLOW(I,J)0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(UVECT(I,J)0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LLOW(I,J)0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LLOW(I,J)0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LLOW(I,J)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (MLLCL(I,J)>D2000) THEN MLLCLtmp=D00 ELSEIF (MLLCL(I,J)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLMH = NINT(LMH(I,J)) P1D(I,J) = PMID(I,J,LLMH) T1D(I,J) = T(I,J,LLMH) @@ -4164,7 +4287,7 @@ SUBROUTINE MISCLN ENDDO CALL CALLCL(P1D,T1D,Q1D,EGRID1,EGRID2) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND SLCL(I,J)=EGRID2(I,J) ENDDO ENDDO @@ -4177,7 +4300,7 @@ SUBROUTINE MISCLN EGRID3,dummy,dummy) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (SLCL(I,J)>D2000) THEN SLCLtmp=D00 ELSEIF (SLCL(I,J)<=D1000) THEN @@ -4215,11 +4338,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(990)) fld_info(cfld)%lvl=LVLSXML(1,IGET(990)) -! $omp parallel do private(i,j,jj) +! $omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4228,7 +4352,7 @@ SUBROUTINE MISCLN !Effective Layer Supercell Parameter IF (IGET(991)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (ESHR(I,J)<10.) THEN ESHRtmp=D00 ELSEIF (ESHR(I,J)>20.0) THEN @@ -4257,11 +4381,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(991)) fld_info(cfld)%lvl=LVLSXML(1,IGET(991)) -! $omp parallel do private(i,j,jj) +! $omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4272,7 +4397,7 @@ SUBROUTINE MISCLN IF (IGET(992)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EGRID1(I,J) = -H99999 EGRID2(I,J) = -H99999 EGRID3(I,J) = -H99999 @@ -4300,7 +4425,7 @@ SUBROUTINE MISCLN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = EGRID3(I,J) ENDDO ENDDO @@ -4309,11 +4434,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(992)) fld_info(cfld)%lvl=LVLSXML(1,IGET(992)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4324,7 +4450,7 @@ SUBROUTINE MISCLN !$omp parallel do private(i,j) ! EGRID3 is Virtual LFC DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Q1D(I,J) ENDDO ENDDO @@ -4332,11 +4458,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(763)) fld_info(cfld)%lvl=LVLSXML(1,IGET(763)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4346,7 +4473,7 @@ SUBROUTINE MISCLN IF (IGET(993)>0) THEN GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LAPSE=-((T700(I,J)-T500(I,J))/((Z700(I,J)-Z500(I,J)))) SHIP=(MUCAPE(I,J)*D1000*MUQ1D(I,J)*LAPSE*(T500(I,J)-K2C)*FSHR(I,J))/HCONST IF (MUCAPE(I,J)<1300.)THEN @@ -4365,11 +4492,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(993)) fld_info(cfld)%lvl=LVLSXML(1,IGET(993)) -! $omp parallel do private(i,j,jj) +! $omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4384,7 +4512,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval ) GRID1(I,J) = CANGLE(I,J) ! IF(EGRID1(I,J)<100. .OR. EGRID2(I,J)>-250.) THEN ! GRID1(I,J) = 0. @@ -4395,11 +4523,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(957)) fld_info(cfld)%lvl=LVLSXML(1,IGET(957)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4411,7 +4540,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID7(I,J) ENDDO ENDDO @@ -4420,11 +4549,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(955)) fld_info(cfld)%lvl=LVLSXML(1,IGET(955)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4436,7 +4566,7 @@ SUBROUTINE MISCLN GRID1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval ) GRID1(I,J) = EGRID8(I,J) ENDDO ENDDO @@ -4445,11 +4575,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(956)) fld_info(cfld)%lvl=LVLSXML(1,IGET(956)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4477,7 +4608,7 @@ SUBROUTINE MISCLN GRID1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T1D(I,J) < spval) GRID1(I,J) = -EGRID6(I,J) ENDDO ENDDO @@ -4486,11 +4617,12 @@ SUBROUTINE MISCLN cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(954)) fld_info(cfld)%lvl=LVLSXML(1,IGET(954)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4530,15 +4662,16 @@ SUBROUTINE MISCLN ! ! RELATIVE HUMIDITY WITH RESPECT TO PRECIPITABLE WATER IF (IGET(749)>0) THEN - CALL CALRH_PW(GRID1(1,jsta)) + CALL CALRH_PW(GRID1(ista:iend,jsta:jend)) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(749)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif diff --git a/sorc/ncep_post.fd/MIXLEN.f b/sorc/ncep_post.fd/MIXLEN.f index 33c02dd7e..767bcad0e 100644 --- a/sorc/ncep_post.fd/MIXLEN.f +++ b/sorc/ncep_post.fd/MIXLEN.f @@ -10,6 +10,7 @@ SUBROUTINE MIXLEN(EL0,EL) ! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT ! 02-06-19 MIKE BALDWIN - WRF VERSION ! 21-03-11 B Cui - change local arrays to dimension (im,jsta:jend) +! 21-09-30 J MENG - 2D DECOMPOSITION ! ! ! INPUT: @@ -42,7 +43,8 @@ SUBROUTINE MIXLEN(EL0,EL) use masks, only: lmh, htm use params_mod, only: EPSQ2, CAPA use ctlblk_mod, only: jsta, jend, jsta_m, jend_m, im, jm, jsta_2l, jend_2u,& - lm, lm1, spval + lm, lm1, spval,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -54,9 +56,9 @@ SUBROUTINE MIXLEN(EL0,EL) ! ! ------------------------------------------------------------------ ! - real,intent(in) :: el0(im,jsta_2l:jend_2u) - real,intent(out) :: EL(IM,jsta_2l:jend_2u,LM) - real HGT(IM,JSTA:JEND),APE(IM,JSTA_M:JEND_M,2) + real,intent(in) :: el0(ista_2l:iend_2u,jsta_2l:jend_2u) + real,intent(out) :: EL(ista_2l:iend_2u,jsta_2l:jend_2u,LM) + real HGT(ISTA:IEND,JSTA:JEND),APE(ISTA_M:IEND_M,JSTA_M:JEND_M,2) ! integer I,J,L real ZL,VKRMZ,ENSQ,Q2KL,ELST,ZIAG,ELVGD @@ -66,13 +68,13 @@ SUBROUTINE MIXLEN(EL0,EL) !$omp parallel do DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EL(I,J,L)=0. ENDDO ENDDO ENDDO DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND HGT(I,J)=ZINT(I,J,NINT(LMH(I,J))+1) ENDDO ENDDO @@ -83,7 +85,7 @@ SUBROUTINE MIXLEN(EL0,EL) !$omp parallel do private(i,j,l,vkrmz,zl) DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(HGT(I,J)=(num_procs-numx))then + jend_m=jm-1 + jend_m2=jm-2 + end if + + if(mod(me+1,numx)==0)then + iend_m=im-1 + iend_m2=im-2 + end if + + 102 format(6i10,a20) + +! if ( me == 0 ) then - idn = MPI_PROC_NULL + idn = MPI_PROC_NULL end if if ( me == num_procs - 1 ) then - iup = MPI_PROC_NULL + iup = MPI_PROC_NULL end if ! -! print *, ' ME, NUM_PROCS = ',me,num_procs -! print *, ' ME, JSTA, JSTA_M, JSTA_M2 = ',me,jsta,jsta_m,jsta_m2 -! print *, ' ME, JEND, JEND_M, JEND_M2 = ',me,jend,jend_m,jend_m2 -! print *, ' ME, IUP, IDN = ',me,iup,idn -! -! counts, disps for gatherv and scatterv -! - do i = 0, num_procs - 1 - call para_range(1,jm,num_procs,i,jsx,jex) - icnt(i) = (jex-jsx+1)*im - idsp(i) = (jsx-1)*im - if ( me == 0 ) then - print *, ' i, icnt(i),idsp(i) = ',i,icnt(i), & - idsp(i) - end if +! GWV. Array of i/j coordinates for bookkeeping tests. Not used in +! calculations but to check if scatter,gather, and exchanges are doing as +! expected. Both real and integer arrays are sent. Integer will be needed +! for very large domains because real mantissas overflow and both coordinates' +! information can't be packed into a real mantisa. Real is easier to use +! because the datatype is the same as for actual data + + allocate(icoords(im,jm)) + allocate(rcoords(im,jm)) + allocate(ibuff(im*jm)) + allocate(rbuff(im*jm)) + do j=1,jm + do i=1,im + icoords(i,j)=10000*I+j ! both I and J information is in each element + rcoords(i,j)=4000*i+j ! both I and J information is in each element but it overflows for large I I to 3600 is safe + end do end do + +! end COORDS test + +! counts, disps for gatherv and scatterv + + isum=1 + allocate(isxa(0:num_procs-1) ) + allocate(jsxa(0:num_procs-1) ) + allocate(iexa(0:num_procs-1) ) + allocate(jexa(0:num_procs-1) ) + do i = 0, num_procs - 1 + call para_range2(im,jm,numx,num_procs/numx,i,isx,iex,jsx,jex) + icnt(i) = ((jex-jsx)+1)*((iex-isx)+1) + isxa(i)=isx + iexa(i)=iex + jsxa(i)=jsx + jexa(i)=jex + + idsp(i)=isumm + isumm=isumm+icnt(i) + if(jsx .eq. 1 .or. jex .eq. jm) then + icnt2(i) = (iex-isx+1) + else + icnt2(i)=0 + endif + idsp2(i)=isumm2 + if(jsx .eq. 1 .or. jex .eq. jm) isumm2=isumm2+(iex-isx+1) + +! GWV Create send buffer for scatter. This is now needed because we are no +! longer sending contiguous slices of the im,jm full state arrays to the +! processors with scatter. Instead we are sending a slice of I and a slice of J +! and so have to reshape the send buffer below to make it contiguous groups of +! isx:iex,jsx:jex arrays + + do jj=jsx,jex + do ii=isx,iex + ibuff(isum)=icoords(ii,jj) + rbuff(isum)=rcoords(ii,jj) + isum=isum+1 + end do + end do + + end do ! enddo of num_procs ! ! extraction limits -- set to two rows ! jsta_2l = max(jsta - 2, 1 ) jend_2u = min(jend + 2, jm ) + if(modelname=='GFS') then + ista_2l=max(ista-2,0) + iend_2u=min(iend+2,im+1) + else + ista_2l=max(ista-2,1) + iend_2u=min(iend+2,im) + endif + ! special for c-grid v jvend_2u = min(jend + 2, jm+1 ) -! special for c-grid v -! print *, ' me, jvend_2u = ',me,jvend_2u ! +! NEW neighbors + + ileft = me - 1 + iright = me + 1 + iup=MPI_PROC_NULL + idn=MPI_PROC_NULL + + if(mod(me,numx) .eq. 0) print *,' LEFT POINT',me + if(mod(me+1,numx) .eq. 0) print *,' RIGHT POINT',me + if(mod(me,numx) .eq. 0) ileft=MPI_PROC_NULL + if(mod(me,numx) .eq. 0) ileftb=me+numx-1 + if(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) iright=MPI_PROC_NULL + if(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) irightb=me-numx+1 + if(me .ge. numx) idn=me-numx + if(me+1 .le. num_procs-numx) iup=me+numx + + print 102,me,ileft,iright,iup,idn,num_procs,'GWVX BOUNDS' + ! allocate arrays + + ibsize = ( (iend-ista) +1) * ( (jend-jsta)+1) + allocate(ibcoords(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(rbcoords(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(ibufs(ibsize)) + allocate(rbufs(ibsize)) + call mpi_scatterv(ibuff,icnt,idsp,mpi_integer & + ,ibufs,icnt(me),mpi_integer ,0,MPI_COMM_WORLD,j) + call mpi_scatterv(rbuff,icnt,idsp,mpi_real & + ,rbufs,icnt(me),mpi_real ,0,MPI_COMM_WORLD,j) + ! -! -! FROM VRBLS3D +!GWV reshape the receive subdomain + + isum=1 + do j=jsta,jend + do i=ista,iend + ibcoords(i,j)=ibufs(isum) + rbcoords(i,j)=rbufs(isum) + isum=isum+1 + end do + end do + +!GWV end reshape + do j=jsta,jend + do i=ista,iend + ii=ibcoords(i,j)/10000 + jj=ibcoords( i,j)-(ii*10000) + if(ii .ne. i .or. jj .ne. j) then + print *,i,j,ii,jj,ibcoords(i,j),' GWVX FAIL ' + else + continue + endif + end do + end do + + allocate(ipoles(im,2),ipole(ista:iend)) + allocate(rpoles(im,2),rpole(ista:iend)) + ipole=9900000 + ipoles=-999999999 + + do i=ista,iend + if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) ipole(i)=ibcoords(i,1) + if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) rpole(i)=rbcoords(i,1) + if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) ipole(i)=ibcoords(i,jm) + if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) rpole(i)=rbcoords(i,jm) + +! check code to be removed upon debugging + if(me .lt. num_procs/2. .and. jsx .eq. 1) then + continue + endif + if(me .gt. num_procs/2. .and. jend_2u .ge. jm) then + continue + endif + end do ! end check code + +! test pole gather + print 105,' GWVX GATHER DISP ',icnt2(me),idsp2(me),me + 105 format(a30,3i12) + + call mpi_gatherv(ipole(ista),icnt2(me),MPI_INTEGER, ipoles,icnt2,idsp2,MPI_INTEGER,0,MPI_COMM_WORLD, ierr ) + call mpi_gatherv(rpole(ista),icnt2(me),MPI_REAL , rpoles,icnt2,idsp2,MPI_REAL ,0,MPI_COMM_WORLD, ierr ) + + if(me .eq. 0) then + do j=1,2 + do i=1,im + ii=rpoles(i,j)/4000 + jj=rpoles(i,j) -ii*4000 + if(ii .ne. i .or. jj .ne. 1 .and. jj .ne. jm ) then + write(0,169)' IPOLES BAD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm + else + continue +! write(0,169)' IPOLES GOOD POINT',rpoles(i,j),ii,i,jj,' jm= ',jm + endif + end do + end do + endif + + 107 format(a20,10i10) + 169 format(a25,f20.1,3i10,a10,4i10) ! print *, ' me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, & 'jvend_2u=',jvend_2u,'im=',im,'jm=',jm,'lm=',lm, & 'lp1=',lp1 + write(0,'(A,5I10)') 'MPI_FIRST me,jsta,jend,ista,iend,=',me,jsta,jend,ista,iend + + end + +! subroutine sub(a) +! return +! end + + + + subroutine fullpole(a,rpoles) + + use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,MODELNAME,numx,& + icoords,ibcoords,rbcoords,bufs,ibufs,me, & + jsta_2l,jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,icnt2,idsp2 +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + include 'mpif.h' +! + real,intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u ),rpoles(im,2) + real, allocatable :: rpole(:) + + integer status(MPI_STATUS_SIZE) + integer ierr + integer size,ubound,lbound + integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc + integer ifirst + data ifirst/0/ + integer iwest,ieast + data iwest,ieast/0,0/ + allocate(rpole(ista:iend)) + + do i=ista,iend + if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) rpole(i)=a(i,1) + if(me .ge. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) rpole(i)=a(i,jm) + end do + + call mpi_allgatherv(rpole(ista),icnt2(me),MPI_REAL,rpoles,icnt2,idsp2,MPI_REAL, MPI_COMM_COMP,ierr) + + call mpi_barrier(mpi_comm_comp,ierr) + ifirst=1 end + diff --git a/sorc/ncep_post.fd/MSFPS.f b/sorc/ncep_post.fd/MSFPS.f index 06b2bc63d..14aa915d4 100644 --- a/sorc/ncep_post.fd/MSFPS.f +++ b/sorc/ncep_post.fd/MSFPS.f @@ -1,25 +1,18 @@ !> @file -! . . . -!> SUBPROGRAM: MSFPS Computes the map scale factor for a Polar -!! Stereographic grid at a give latitude. -!! -!! ABSTRACT: -!! Computes the map scale factor for a Polar Stereographic -!! grid at a give latitude. -!! -!! PROGRAM HISTORY LOG: -!! 06-11-01 SWIPED FROM WRF SI PACKAGE BY ROZUMALSKI -!! -!! INPUT ARGUMENT LIST: -!! LAT - LATITUDE AT WHICH MAP FACTOR IS VALID -!! TRUELAT1 - TRUELAT 1 -!! -!! OUTPUT ARGUMENT LIST: -!! MSF - MAP SCALE FACTOR -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! +!> @brief msfps() computes the map scale factor for a polar stereographic grid at a give latitude. +!> +!> This subroutine computes the map scale factor for a polar stereographic grid at a give latitude. +!> +!> @param[in] LAT Latitude at which map factor is valid. +!> @param[in] TRUELAT1 TRUELAT 1. +!> @param[out] MSF Map scale factor. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2006-11-01 | Rozumalski | Swiped from WRF si package +!> +!> @author Rozumalski @date 2006-11-01 SUBROUTINE MSFPS(LAT,TRUELAT1,MSF) diff --git a/sorc/ncep_post.fd/NGMFLD.f b/sorc/ncep_post.fd/NGMFLD.f index 7bd962e14..2d7052e35 100644 --- a/sorc/ncep_post.fd/NGMFLD.f +++ b/sorc/ncep_post.fd/NGMFLD.f @@ -1,81 +1,48 @@ !> @file -! . . . -!> SUBPROGRAM: NGMFLD COMPUTES LAYER MEAN NGM FIELDS -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES A HANDFUL OF NGM LAYER MEAN -!! FIELDS. THIS IS DONE TO PROVIDE A FULLY COMPLETE -!! ETA NGM LOOK-ALIKE OUTPUT FILE. THE SIGMA (LAYER) -!! FIELDS COMPUTED BY THIS ROUTINE ARE TABULATED BELOW. -!! -!! SIGMA (LAYER) FIELD(S) -!! --------------- -------------- -!! 0.47191-1.00000 RH -!! 0.47171-0.96470 RH -!! 0.18019-0.47191 RH -!! 0.84368-0.98230 RH -!! 0.85000-1.00000 MCONV -!! WHERE -!! RH = RELATIVE HUMIDITY -!! MCONV = MOISTURE CONVERGENCE -!! -!! LAYER MEANS ARE A SUMMATION OVER ETA LAYERS MAPPING INTO -!! THE PRESSURE RANGE CORRESPONDING TO THE SIGMA RANGE ABOVE. -!! THE CALCULATION OF THESE BOUNDING PRESSURES IS DONE AT -!! EACH HORIZONTAL GRID POINT BASED ON THE SURFACE PRESSURE. -!! EACH TERM IN THE SUMMATION IS WEIGHTED BY THE THICKNESS OF -!! THE ETA LAYER. THE FINAL LAYER MEAN IS THIS SUM NORMALIZED -!! BY THE TOTAL DEPTH OF THE LAYER. - -!! -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 93-07-27 RUSS TREADON - MODIFIED SUMMATION LIMITS FROM -!! 0.66*PSFC TO 0.75*PSFC AND 0.33*PSFC -!! TO 0.50*PSFC, WHERE PSFC IS THE -!! SURFACES PRESSURE. THE REASON FOR -!! THIS CHANGE WAS RECOGNITION THAT IN -!! THE LFM 0.33 AND 0.66 WERE MEASURED -!! FROM THE SURFACE TO THE TROPOPAUSE, -!! NOT THE TOP OF THE MODEL. -!! 93-09-13 RUSS TREADON - RH CALCULATIONS WERE MADE INTERNAL -!! TO THE ROUTINE. -!! 98-06-16 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 98-08-18 MIKE BALDWIN - COMPUTE RH OVER ICE -!! 98-12-22 MIKE BALDWIN - BACK OUT RH OVER ICE -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-24 MIKE BALDWIN - WRF VERSION -!! -!! -!! USAGE: CALL NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! RH4710 - SIGMA LAYER 0.47-1.00 MEAN RELATIVE HUMIDITY. -!! RH4796 - SIGMA LAYER 0.47-0.96 MEAN RELATIVE HUMIDITY. -!! RH1847 - SIGMA LAYER 0.18-0.47 MEAN RELATIVE HUMIDITY. -!! RH8498 - SIGMA LAYER 0.84-0.98 MEAN RELATIVE HUMIDITY. -!! QM8510 - SIGMA LAYER 0.85-1.00 MEAN MOISTURE CONVERGENCE. -!! -!! OUTPUT FILES: -!! NONE -!! -!! LIBRARY: -!! COMMON - -!! MASKS -!! OPTIONS -!! LOOPS -!! MAPOT -!! DYNAMD -!! INDX -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief ngmfld() computes layer mean NGM fields +!> +!> This routine computes a handful of NGM layer mean +!> fields. This is done to provide a fully complete +!> ETA NGM look-alike output file. +!> ### The sigma (layer) fields computed bu this routine are tabulated below. +!> Sigma (layer) | Field(s) | +!> --------------|----------| +!> 0.47191 - 1.00000 | RH | +!> 0.47171 - 0.96470 | RH | +!> 0.18019 - 0.47191 | RH | +!> 0.84368 - 0.98230 | RH | +!> 0.85000 - 1.00000 | MCONV | +!> where RH = Relative humidity and MCONV = Moisture convergence +!> +!> Layer means are a summation over ETA layers mapping into +!> The pressure range corresponding to the sigma range above. +!> The calculation of these bounding pressures is done at +!> each horizontal grid point based on the surface pressure. +!> Each term in the summation is weighted by the thickness of +!> the ETA layer. The final layer mean is this sum normalized +!> by the total depth of the layer. +!> +!> @param[out] RH4710 Sigma layer 0.47-1.00 mean relative humidity. +!> @param[out] RH4796 Sigma layer 0.47-0.96 mean relative humidity. +!> @param[out] RH1847 Sigma layer 0.18-0.47 mean relative humidity. +!> @param[out] RH8498 Sigma layer 0.84-0.98 mean relative humidity. +!> @param[out] QM8510 Sigma layer 0.85-1.00 mean moisture convergence. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1993-07-27 | Russ Treadon | Modified summation limits from 0.66*PSFC to 0.75*PSFC and 0.33*PSFC to 0.50*PSFC, where PSFC is the surfaces pressure. The reason for this change was recognition that in the LFM 0.33 and 0.66 were measured from the surface to the tropopause not the top of the model. +!> 1993-09-13 | Russ Treadon | RH calculations were made internal to the routine. +!> 1996-03-04 | Mike Baldwin | Change PW CALC to include CLD WTR +!> 1998-06-16 | T Black | Conversion from 1-D to 2-D +!> 1998-08-17 | Mike Baldwin | Compute RH over ice +!> 1998-12-22 | Mike Baldwin | Back out RH over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-24 | Mike Baldwin | WRF Version +!> 2021-09-30 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ! @@ -85,7 +52,8 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) use masks, only: lmh use params_mod, only: d00, d50, h1m12, pq0, a2, a3, a4, h1, d01, small use ctlblk_mod, only: jsta, jend, lm, jsta_2l, jend_2u, jsta_m2, jend_m2,& - spval, im + spval, im, & + ista, iend, ista_2l, iend_2u, ista_m2, iend_m2, ista_m, iend_m ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -96,10 +64,10 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ! ! DECLARE VARIABLES. LOGICAL GOT8510,GOT4710,GOT4796,GOT1847,GOT8498 - REAL,dimension(IM,jsta_2l:jend_2u),intent(out) :: QM8510,RH4710,RH8498, & + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u),intent(out) :: QM8510,RH4710,RH8498, & RH4796,RH1847 - REAL,dimension(im,jsta_2l:jend_2u) :: Z8510,Z4710,Z8498,Z4796,Z1847 - real,dimension(im,jsta_2l:jend_2u) :: Q1D, U1D, V1D, QCNVG + REAL,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: Z8510,Z4710,Z8498,Z4796,Z1847 + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: Q1D, U1D, V1D, QCNVG ! integer I,J,L real P100,P85,P98,P96,P84,P47,P18,ALPM,DE,PM,TM,QM, & @@ -110,7 +78,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ! INITIALIZE ARRAYS. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND QM8510(I,J) = D00 RH4710(I,J) = D00 RH8498(I,J) = D00 @@ -137,7 +105,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ! COMPUTE MOISTURE CONVERGENCE !$omp parallel do private(i,j) DO J=JSTA_2L,JEND_2U - DO I=1,IM + DO I=ISTA_2L,IEND_2U Q1D(I,J) = Q(I,J,L) U1D(I,J) = UH(I,J,L) V1D(I,J) = VH(I,J,L) @@ -146,7 +114,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) CALL CALMCVG(Q1D,U1D,V1D,QCNVG) ! COMPUTE MOISTURE CONVERGENCE DO J=JSTA_M2,JEND_M2 - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! ! SET TARGET PRESSURES. @@ -220,7 +188,7 @@ SUBROUTINE NGMFLD(RH4710,RH4796,RH1847,RH8498,QM8510) ENDDO ! DO J=JSTA_M2,JEND_M2 - DO I=2,IM-1 + DO I=ISTA_M,IEND_M ! NORMALIZE TO GET LAYER MEAN VALUES. IF (Z8510(I,J)>0) THEN QM8510(I,J) = QM8510(I,J)/Z8510(I,J) diff --git a/sorc/ncep_post.fd/NGMSLP.f b/sorc/ncep_post.fd/NGMSLP.f index 56fdda56c..40f8bdb1c 100644 --- a/sorc/ncep_post.fd/NGMSLP.f +++ b/sorc/ncep_post.fd/NGMSLP.f @@ -65,6 +65,7 @@ !! CONSISTENT WITH MESINGER SLP !! 02-06-13 MIKE BALDWIN - WRF VERSION !! 06-12-18 H CHUANG - BUG FIX TO CORRECT TAU AT SFC +!! 21-09-30 J MENG - 2D DECOMPOSITION !! !! USAGE: CALL NGMSLP !! INPUT ARGUMENT LIST: @@ -93,7 +94,7 @@ SUBROUTINE NGMSLP use vrbls2d, only: slp, fis, z1000 use masks, only: lmh use params_mod, only: rd, gi, g, h1, d608, gamma, d50, p1000 - use ctlblk_mod, only: jsta, jend, im, jm, spval + use ctlblk_mod, only: jsta, jend, im, jm, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -117,7 +118,7 @@ SUBROUTINE NGMSLP !!$omp& tau,tauavg,tausfc,tausl,tavg,tvrbar,tvrsfc,tvrsl, !!$omp& tvrt,tvrtal,zbar,zl,zsfc) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLMH = NINT(LMH(I,J)) if( PINT(I,J,LLMH+1) @file -! -!> SUBPROGRAM: OTLFT COMPUTES LIFTED INDEX -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-03-10 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES LIFTS A PARCEL SPECIFIED BY THE -!! PASSED PRESSURE, TEMPERATURE, AND SPECIFIC HUMIDITY TO -!! 500MB AND THEN COMPUTES A LIFTED INDEX. THIS LIFTED -!! LIFTED INDEX IS THE DIFFERENCE BETWEEN THE LIFTED -!! PARCEL'S TEMPERATURE AT 500MB AND THE AMBIENT 500MB -!! TEMPERATURE. -!! -!! PROGRAM HISTORY LOG: -!! 93-03-10 RUSS TREADON - MODIFIED OTLIFT2 TO LIFT PARCELS -!! SPECIFIED BY PASSED P, T, AND Q. -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-06-17 MIKE BALDWIN - WRF VERSION -!! 11-04-12 GEOFF MANIKIN - USE VIRTUAL TEMPERATURE -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! -!! USAGE: CALL OTLFT(PBND,TBND,QBND,SLINDX) -!! INPUT ARGUMENT LIST: -!! PBND - PARCEL PRESSURE. -!! TBND - PARCEL TEMPERATURE. -!! QBND - PARCEL SPECIFIC HUMIDITY. -!! -!! OUTPUT ARGUMENT LIST: -!! SLINDX - LIFTED INDEX. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! LOOPS -!! MASKS -!! PHYS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief otlft() computes lifted index. +!> +!> This routine computes lifts a parcel specified by the +!> passed pressure, temperature, and specific humidity to +!> 500mb and then computes a lifted index. This lifted +!> lifted index is the difference between the lifted +!> parcel's temperature at 500mb and the ambient 500mb +!> temperature. +!> +!> @param[in] PBND Parcel pressure. +!> @param[in] TBND Parcel temperature. +!> @param[in] QBND Parcel specific humidity. +!> @param[out] SLINDX Lifted index. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-03-10 | Russ Treadon | Initial. Modified OTLIFT2 to lift parcels specified by passed P, T, and Q. +!> 1998-06-15 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-17 | Mike Baldwin | WRF Version +!> 2011-04-12 | Geoff Manikin | Use virtual temperature +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-09-30 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1993-03-10 SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX) ! @@ -52,7 +32,7 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX) use vrbls2d, only: T500 use lookup_mod, only: THL, RDTH, JTB, QS0, SQS, RDQ, ITB, PTBL, & PL, RDP, THE0, STHE, RDTHE, TTBL - use ctlblk_mod, only: JSTA, JEND, IM, spval + use ctlblk_mod, only: JSTA, JEND, IM, spval, ISTA, IEND use params_mod, only: D00, H10E5, CAPA, ELOCP, EPS, ONEPS use upp_physics, only: FPVSNEW !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -63,8 +43,8 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX) ! ! DECLARE VARIABLES. - real,dimension(IM,jsta:jend),intent(in) :: PBND,TBND,QBND - real,dimension(IM,jsta:jend),intent(out) :: SLINDX + real,dimension(ista:iend,jsta:jend),intent(in) :: PBND,TBND,QBND + real,dimension(ista:iend,jsta:jend),intent(out) :: SLINDX REAL :: TVP, ESATP, QSATP REAL :: BQS00, SQS00, BQS10, SQS10, P00, P10, P01, P11, BQ, SQ, TQ REAL :: BTHE00, STHE00, BTHE10, STHE10, BTH, STH, TTH @@ -81,7 +61,7 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX) ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND SLINDX(I,J) = D00 ENDDO ENDDO @@ -89,7 +69,7 @@ SUBROUTINE OTLFT(PBND,TBND,QBND,SLINDX) !--------------FIND EXNER IN BOUNDARY LAYER----------------------------- ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TBT = TBND(I,J) QBT = QBND(I,J) ! diff --git a/sorc/ncep_post.fd/OTLIFT.f b/sorc/ncep_post.fd/OTLIFT.f index f1abe6575..2270113da 100644 --- a/sorc/ncep_post.fd/OTLIFT.f +++ b/sorc/ncep_post.fd/OTLIFT.f @@ -1,44 +1,28 @@ !> @file -! -!> SUBPROGRAM: OTLIFT COMPUTES SFC TO 500MB LIFTED INDEX -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-03-10 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES A SURFACE TO 500MB LIFTED INDEX. -!! THE LIFTED PARCEL IS FROM THE FIRST ATMOSPHERIC ETA -!! LAYER (IE, THE ETA LAYER CLOSEST TO THE MODEL GROUND). -!! THE LIFTED INDEX IS THE DIFFERENCE BETWEEN THIS PARCEL'S -!! TEMPERATURE AT 500MB AND THE AMBIENT 500MB TEMPERATURE. -!! -!! PROGRAM HISTORY LOG: -!! ??-??-?? ??? - SUBROUTINE OTLIFT IN ETA MODEL. -!! 93-03-10 RUSS TREADON - ADAPTED OTLIFT FOR USE WITH NEW POST. -!! 98-06-18 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-11 MIKE BALDWIN - WRF VERSION -!! 11-04-12 GEOFF MANIKIN - USE VIRTUAL TEMPERATURE -!! 20-11-10 JESSE MENG - USE UPP_PHYSICS MODULE -!! -!! USAGE: CALL OTLIFT(SLINDX) -!! INPUT ARGUMENT LIST: -!! -!! OUTPUT ARGUMENT LIST: -!! SLINDX - LIFTED INDEX. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief otlift() computes SFC to 500mb lifted index. +!> +!> This routine computes a surface to 500mb lifted index. +!> The lifted parcel is from the first atmpspheric ETA +!> layer (ie, the ETA layer closest to the model ground). +!> The lifted index is the difference between this parcel's +!> temperature at 500mb and the ambient 500mb temperature. +!> +!> @param[out] SLINDX lifted index. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> ????-??-?? | ??? | Subroutine OTLIFT in ETA model. +!> 1993-03-10 | Russ Treadon | Adapted OTLIFT for use with new post. +!> 1998-06-18 | T Black | Conversion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2001-10-25 | H Chuang | Modified to process hybrid model output +!> 2002-06-11 | Mike Baldwin | WRF Version +!> 2011-04-12 | Geoff Manikin | Use virtual temperature +!> 2020-11-10 | Jesse Meng | Use UPP_PHYSICS Module +!> 2021-09-30 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1993-03-10 SUBROUTINE OTLIFT(SLINDX) ! @@ -47,7 +31,7 @@ SUBROUTINE OTLIFT(SLINDX) use masks, only: LMH use lookup_mod, only: THL, RDTH, JTB, QS0, SQS, RDQ,ITB, PTBL, PL, & RDP, THE0, STHE, RDTHE, TTBL - use ctlblk_mod, only: JSTA, JEND, IM, SPVAL + use ctlblk_mod, only: JSTA, JEND, IM, SPVAL, ISTA, IEND use params_mod, only: D00,H10E5, CAPA, ELOCP, EPS, ONEPS use upp_physics, only: FPVSNEW ! @@ -60,7 +44,7 @@ SUBROUTINE OTLIFT(SLINDX) ! ! DECLARE VARIABLES. - real,intent(out) :: SLINDX(IM,jsta:jend) + real,intent(out) :: SLINDX(ista:iend,jsta:jend) REAL :: TVP, ESATP, QSATP REAL :: TTH, TP, APESP, PARTMP, THESP, TPSP REAL :: BQS00, SQS00, BQS10, SQS10, BQ, SQ, TQ @@ -77,13 +61,13 @@ SUBROUTINE OTLIFT(SLINDX) ! INTIALIZE LIFTED INDEX ARRAY TO ZERO. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND SLINDX(I,J) = D00 ENDDO ENDDO !--------------FIND EXNER AT LOWEST LEVEL------------------------------- DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LBTM=NINT(LMH(I,J)) IF(T(I,J,LBTM) @file -! -!> SUBPROGRAM: PARA_RANGE SET UP DECOMPOSITION VALUES -!! PRGRMMR: TUCCILLO ORG: IBM -!! -!! ABSTRACT: -!! SETS UP DECOMOSITION VALUES -!! -!! PROGRAM HISTORY LOG: -!! 00-01-06 TUCCILLO - ORIGINAL +!> @brief para_range() sets up decomposition values. +!> +!> This subroutine sets up decomposition values. +!> +!> @param[in] N1 First interate value. +!> @param[in] N2 Last interate value. +!> @param[in] NPROCS Number of MPI tasks. +!> @param[in] IRANK My taks ID. +!> @param[out] ISTA First loop value. +!> @param[out] IEND Last loop value. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-01-06 | Jim Tuccillo | Initial +!> +!> @author Jim Tuccillo IBM @date 2000-01-06 + SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) + + implicit none + integer,intent(in) :: n1,n2,nprocs,irank + integer,intent(out) :: ista,iend + integer iwork1, iwork2 + + iwork1 = ( n2 - n1 + 1 ) / nprocs + iwork2 = mod ( n2 - n1 + 1, nprocs ) + ista = irank * iwork1 + n1 + min ( irank, iwork2 ) + iend = ista + iwork1 - 1 + if ( iwork2 > irank ) iend = iend + 1 + return + end !! -!! USAGE: CALL PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND)(A) +!! USAGE: CALL PARA_RANGE2(N1,N2,NX,NY,NRANK,ISTA,IEND,JSTA,JEND)(A) !! INPUT ARGUMENT LIST: -!! N1 - FIRST INTERATE VALUE -!! N2 - LAST INTERATE VALUE -!! NPROCS - NUMBER OF MPI TASKS -!! IRANK - MY TAKS ID +!! N1 - LAAT INTERATE VALUE I dimension +!! N2 - LAST INTERATE VALUE J dimension +!! NX NUMBER OF subdomains in Z dimension +!! NY NUMBER OF subdomains in Y dimension +!! NX * NY should be the total number of MPI procs +!! NRANK - MY TAKS ID !! !! OUTPUT ARGUMENT LIST: -!! ISTA - FIRST LOOP VALUE -!! IEND - LAST LOOP VALUE +!! ISTA - FIRST LOOP VALUE I +!! IEND - LAST LOOP VALUE I +!! JSTA - FIRST LOOP VALUE J +!! JEND - LAST LOOP VALUE J !! !! OUTPUT FILES: !! STDOUT - RUN TIME STANDARD OUT. @@ -32,18 +58,20 @@ !! LANGUAGE: FORTRAN !! MACHINE : IBM RS/6000 SP !! - SUBROUTINE PARA_RANGE (N1,N2,NPROCS,IRANK,ISTA,IEND) + subroutine para_range2(im,jm,nx,ny,nrank,ista,iend,jsta,jend) implicit none - integer,intent(in) :: n1,n2,nprocs,irank - integer,intent(out) :: ista,iend - integer iwork1, iwork2 + integer,intent(in) :: im,jm,nx,ny,nrank + integer,intent(out) :: ista,iend,jsta,jend + integer :: ix,jx + + jx=nrank/nx + ix=nrank-(jx*nx) + call para_range(1,im,nx,ix,ista,iend) + call para_range(1,jm,ny,jx,jsta,jend) +! print 101,n,ix,jx,ista,iend,jsta,jend +! 101 format(16i8) + return + end - iwork1 = ( n2 - n1 + 1 ) / nprocs - iwork2 = mod ( n2 - n1 + 1, nprocs ) - ista = irank * iwork1 + n1 + min ( irank, iwork2 ) - iend = ista + iwork1 - 1 - if ( iwork2 > irank ) iend = iend + 1 - return - end diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 034de6caf..64c9c35de 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -1,53 +1,30 @@ !> @file -! -!> SUBPROGRAM: PROCESS DRIVER FOR MAJOR POST ROUTINES. -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-21 -!! -!! ABSTRACT: -!! THIS ROUTINE CALLS THE MAJOR POST PROCESSOR ROUTINES. -!! THESE ROUTINES ARE -!! MDLFLD - CALCULATE NMC SLP, SET BELOW SURFACE FIELDS, -!! AND POSTS DATA ON MODEL SURFACES. -!! MDL2P - POSTS DATA ON ISOBARIC SURFACES. -!! SURFCE - POSTS SOUNDING DATA, SURFACE BASED FIELDS, -!! AND STATIC OR FIXED FIELDS. -!! CLDRAD - POST SOUNDING/CLOUD/RADIATION FIELDS. -!! MISCLN - POST MISCELLANEOUS (SPECIAL) FIELDS. -!! FIXED - POST FIXED FIELDS. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-21 RUSS TREADON -!! 98-06-01 T BLACK - CONVERSION OF POST FROM 1-D TO 2-D -!! 00-01-05 JIM TUCCILLO - MPI VERSION -!! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -!! 02-06-19 MIKE BALDWIN - WRF VERSION -!! 11-02-04 Jun Wang - add grib2 option -!! -!! USAGE: CALL PROCESS -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! MDLFLD - POST DATA MDL SURFACES. -!! MDL2P - POST DATA ON PRESSURE SURFACES. -!! SURFCE - POST SURFACE BASED FIELDS. -!! CLDRAD - POST SOUNDING/CLOUD/RADIATION FIELDS. -!! MISCLN - POST MISCELLANEOUS FIELDS. -!! FIXED - POST FIXED FIELDS. -!! LIBRARY: -!! COMMON - OUTGRD -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief process() is a driver for major post routines. +!> +!> This routine calls the major post processor routines. +!> 
+!> These routines are
+!> MDLFLD  - Calculate NMC SLP, set below surface fields,
+!>           and posts data on model surfaces.
+!> MDL2P   - Posts data on isobaric surfaces.
+!> SURFCE  - Posts sounding data  surface based fields,
+!>           and static or fixed fields.
+!> CLDRAD  - Post sounding/cloud/radiation fields.
+!> MISCLN  - Post miscellaneous (special) fields.
+!> FIXED   - Post fixed fields.
+!>
+!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-21 | Russ Treadon | Initial +!> 1998-06-01 | T Black | Conversion from 1-D to 2-D +!> 2000-01-05 | Jim Tuccillo | MPI Version +!> 2001-10-25 | H CHUANG | Modified to process hybrid model output +!> 2002-06-19 | Mike Baldwin | WRF Version +!> 2011-02-04 | Jun Wang | Add grib2 option +!> +!> @author Russ Treadon W/NP2 @date 1992-12-21 SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! !---------------------------------------------------------------------------- @@ -76,37 +53,45 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! START SUBROUTINE PROCESS. ! cfld=0 + if(me==0) write(0,*) "PROCESS starts" ! ! COMPUTE/POST FIELDS ON MDL SURFACES. ! btim = mpi_wtime() CALL MDLFLD + if(me==0) write(0,*) "PROCESS MDLFLD done" ETAFLD2_tim = ETAFLD2_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON PRESSURE SURFACES. btim = mpi_wtime() CALL MDL2P(iostatusD3D) + if(me==0) write(0,*) "PROCESS MDL2P done" ETA2P_tim = ETA2P_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON SIGMA SURFACES. btim = mpi_wtime() CALL MDL2SIGMA + if(me==0) write(0,*) "PROCESS MDL2SIGMA done" CALL MDL2SIGMA2 + if(me==0) write(0,*) "PROCESS MDL2SIGMA2 done" MDL2SIGMA_tim = MDL2SIGMA_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON AGL SURFCES. btim = mpi_wtime() CALL MDL2AGL + if(me==0) write(0,*) "PROCESS MDL2AGL done" MDL2AGL_tim = MDL2AGL_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST SURFACE RELATED FIELDS. btim = mpi_wtime() CALL SURFCE + if(me==0) write(0,*) "PROCESS SURFCE done" SURFCE2_tim = SURFCE2_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST SOUNDING AND CLOUD RELATED FIELDS. btim = mpi_wtime() CALL CLDRAD + if(me==0) write(0,*) "PROCESS CLDRAD done" CLDRAD_tim = CLDRAD_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST TROPOPAUSE DATA, FD LEVEL FIELDS, @@ -114,6 +99,7 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! AND LFM-NGM LOOK-ALIKE FIELDS. btim = mpi_wtime() CALL MISCLN + if(me==0) write(0,*) "PROCESS MISCLN done" MISCLN_tim = MISCLN_tim +(mpi_wtime() - btim) ! COMPUTE/POST TROPOPAUSE DATA, FD LEVEL FIELDS, @@ -121,27 +107,32 @@ SUBROUTINE PROCESS(kth,kpv,th,pv,iostatusD3D) ! AND LFM-NGM LOOK-ALIKE FIELDS. btim = mpi_wtime() CALL MDL2STD_P + if(me==0) write(0,*) "PROCESS MDL2STD_P done" MDL2STD_tim = MDL2STD_tim +(mpi_wtime() - btim) ! ! POST FIXED FIELDS. btim = mpi_wtime() CALL FIXED + if(me==0) write(0,*) "PROCESS FIXED done" FIXED_tim = FIXED_tim +(mpi_wtime() - btim) ! ! COMPUTE/POST FIELDS ON SIGMA SURFACES. btim = mpi_wtime() CALL MDL2THANDPV(kth,kpv,th,pv) + if(me==0) write(0,*) "PROCESS MDL2THANDPV done" MDL2THANDPV_tim = MDL2THANDPV_tim +(mpi_wtime() - btim) ! ! POST RADIANCE AND BRIGHTNESS FIELDS. btim = mpi_wtime() CALL CALRAD_WCLOUD + if(me==0) write(0,*) "PROCESS CALRAD_WCLOUD done" CALRAD_WCLOUD_tim = CALRAD_WCLOUD_tim +(mpi_wtime() - btim) ! ! END OF ROUTINE. ! NTLFLD=cfld if(me==0)print *,'nTLFLD=',NTLFLD + if(me==0) write(0,*) "PROCESS done" ! RETURN END diff --git a/sorc/ncep_post.fd/SCLFLD.f b/sorc/ncep_post.fd/SCLFLD.f index fc4087ea8..4450bb9f4 100644 --- a/sorc/ncep_post.fd/SCLFLD.f +++ b/sorc/ncep_post.fd/SCLFLD.f @@ -1,48 +1,34 @@ !> @file -! -!> SUBPROGRAM: SCLFLD SCALE ARRAY ELEMENT BY CONSTANT -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-09-13 -!! -!! ABSTRACT: -!! THIS ROUTINE MULTIPLES (SCALES) THE FIRST IMO*JMO -!! ELEMENTS OF ARRAY FLD BY THE REAL SCALAR SCALE. -!! ARRAY ELEMENTS WHICH EQUAL A SPECIAL VALUE WILL -!! NOT BE SCALED BY SCALE. THEY WILL BE LEFT AS IS. -!! THE SPECIAL VALUE, SPVAL, IS PASSED THROUGH COMMON -!! BLOCK OPTIONS. IT IS SET IN INCLUDE FILE OPTIONS. -!! -!! PROGRAM HISTORY LOG: -!! 92-09-13 RUSS TREADON -!! 00-01-04 JIM TUCCILLO -!! -!! USAGE: CALL SCLFLD(FLD,SCALE,IMO,JMO) -!! INPUT ARGUMENT LIST: -!! FLD - ARRAY WHOSE ELEMENTS ARE TO BE SCALED. -!! SCALE - CONSTANT BY WHICH TO SCALE ELEMENTS OF FLD. -!! IMO,JMO - DIMENSION OF ARRAY FLD. -!! -!! OUTPUT ARGUMENT LIST: -!! FLD - ARRAY WHOSE ELEMENTS HAVE BEEN SCALED BY SCALE. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - OPTIONS -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief sclfld() scale array element by constant. +!> +!> @author Russ Treadon W/NP2 @date 1992-09-13 + +!> This routine multiples (scales) the first IMO*JMO +!> elements of array fld by the real scalar scale. +!> Array elements which equal a special value will +!> not be scaled by scale. They will be left as is. +!> The special value, spval, is passed through common +!> block options. It is set in include file options. +!> +!> @param[in] FLD Array whose elements are to be scaled. +!> @param[in] SCALE Constant by which to scale elements of fld. +!> @param[in] IMO,JMO Dimension of array fld. +!> @param[out] FLD Array whose elements have been scaled by scale. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-09-13 | Russ Treadon | Initial +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2021-09-29 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-09-13 SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO) ! ! use params_mod, only: small - use ctlblk_mod, only: jsta, jend, spval + use ctlblk_mod, only: jsta, jend, spval, ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -50,7 +36,7 @@ SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO) ! integer,intent(in) :: IMO,JMO REAL,intent(in) :: SCALE - REAL,dimension(imo,jmo),intent(inout) :: FLD + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: FLD integer I,J ! ! @@ -61,7 +47,7 @@ SUBROUTINE SCLFLD(FLD,SCALE,IMO,JMO) ! !$omp parallel do DO J=JSTA,JEND - DO I=1,IMO + DO I=ISTA,IEND IF(ABS(FLD(I,J)-SPVAL)>SMALL) FLD(I,J)=SCALE*FLD(I,J) ENDDO ENDDO diff --git a/sorc/ncep_post.fd/SELECT_CHANNELS.f b/sorc/ncep_post.fd/SELECT_CHANNELS.f index f78828044..8964566a0 100644 --- a/sorc/ncep_post.fd/SELECT_CHANNELS.f +++ b/sorc/ncep_post.fd/SELECT_CHANNELS.f @@ -1,27 +1,21 @@ !> @file -! -!> SELECT_CHANNEL -!! @author HWRF @date 20120927 -!! -!! Verify channel information and print error to output file if -!! detected, finally excuting a program STOP - which may cause -!! a hang condifition if run on multiple processors. -!! If data passed validation the channel indices passed in via -!! the "channels" array are stored in the structure defining -!! the channel object -!! -!! @param[inout] channelinfo - structure defining channel object -!! @param[in] nchannels - number of channels for sensor -!! @param[in] channels -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: NONE -!! -!! LIBRARY: NONE -!! +!> @brief select_channels() verifies channel information. +!> +!> @author HWRF @date 2012-09-27 + +!> This subroutine verifies channel information and print error to output file if +!> detected, finally excuting a program STOP - which may cause +!> a hang condifition if run on multiple processors. +!> +!> If data passed validation the channel indices passed in via +!> the "channels" array are stored in the structure defining +!> the channel object. +!> +!> @param[inout] channelinfo structure defining channel object. +!> @param[in] nchannels number of channels for sensor. +!> @param[in] channels. +!> +!> @author HWRF @date 2012-09-27 subroutine SELECT_CHANNELS(channelinfo,nchannels,channels) use crtm_channelinfo_define, only: crtm_channelinfo_type diff --git a/sorc/ncep_post.fd/SETUP_SERVERS.f b/sorc/ncep_post.fd/SETUP_SERVERS.f index 9f2a2b084..8acd4332b 100644 --- a/sorc/ncep_post.fd/SETUP_SERVERS.f +++ b/sorc/ncep_post.fd/SETUP_SERVERS.f @@ -1,56 +1,22 @@ !> @file -! . . . -!> SUBROUTINE: SETUP_SERVERS SETUP I/O SERVERS -!! PRGRMMR: TUCCILLO ORG: IBM DATE: 00-03-20 -!! -!! ABSTRACT: SETUP I/O SERVERS -!! -!! PROGRAM HISTORY LOG: -!! 00-03-11 TUCCILLO - ORIGINATOR -!! -!! USAGE: CALL SETUP_SERVERS(MYPE, -!! * NPES, -!! * INUMQ, -!! * MPI_COMM_COMP, -!! * MPI_COMM_INTER) -!! -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! MYPE - MY RANK -!! INUMQ - ARRAY THAT HOLDS THE NUMBER OF SERVERS IN EACH GROUP -!! NPES - NUMBER OF MPI TASKS FOR POSTING -!! MPI_COMM_COMP - THE NEW INTRACOMMUNICATOR FOR ALL TASKS -!! MPI_COMM_INTER - THE INTERCOMMUNICATOR FOR THE I/O SERVERS -!! -!! INPUT FILES: NONE -!! -!! OUTPUT FILES: -!! -!! SUBPROGRAMS CALLED: -!! UNIQUE: -!! PARA_RANGE -!! MPI_INIT -!! MPI_COMM_RANK -!! MPI_COMM_SIZE -!! MPI_COMM_DUP -!! MPI_COMM_SPLIT -!! MPI_COMM_GROUP -!! MPI_GROUP_EXCL -!! MPI_COMM_CREATE -!! MPI_GROUP_FREE -!! MPI_INTERCOMM_CREATE -!! MPI_BARRIER -!! -!! EXIT STATES: -!! COND = 0 - NORMAL EXIT -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM SP -!! -!! +!> @brief setup_servers() setups I/O servers. +!> +!> @author Jim Tuccillo IBM @date 2000-03-20 + +!> This subroutine is to setup I/O servers. +!> +!> @param[out] MYPE My rank. +!> @param[out] INUMQ Array that holds the number of servers in each group. +!> @param[out] NPES Number of MPI tasks for posting. +!> @param[out] MPI_COMM_COMP The new intracommunicator for all tasks. +!> @param[out] MPI_COMM_INTER The intercommunicator for the I/O servers. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-03-20 | Jim Tuccillo | Initial +!> +!> @author Jim Tuccillo IBM @date 2000-03-20 SUBROUTINE SETUP_SERVERS(MYPE, & & NPES, & & INUMQ, & diff --git a/sorc/ncep_post.fd/SET_OUTFLDS.f b/sorc/ncep_post.fd/SET_OUTFLDS.f index a12d60106..a21f98fa5 100644 --- a/sorc/ncep_post.fd/SET_OUTFLDS.f +++ b/sorc/ncep_post.fd/SET_OUTFLDS.f @@ -1,43 +1,25 @@ !> @file -! . . . -!> SUBPROGRAM: READCNTRLgrb2_xml READS POST xml CONTROL FILE -!! PRGRMMR: J. WANG ORG: NCEP/EMC DATE: 12-01-27 -!! -!! ABSTRACT: -!! THIS ROUTINE READS THE CONTROL FILE IN XML FORMAT SPECIFYING -!! FIELD(S) TO POST, AND SAVE ALL THE FIELD INFORMATION IN -!! A DATATYPE array PSET -!! -!! PROGRAM HISTORY LOG: -!! 01_27_2012 Jun Wang - INITIAL CODE -!! 03_10_2015 Lin Gan - Replace XML file with flat file implementation -!! 10_30_2019 Bo CUI - REMOVE "GOTO" STATEMENT +!> @ brief set_outflds() reads post xml control file. +!> +!> @author J. Wang NCEP/EMC @date 2012-01-27 -!! -!! USAGE: CALL READCNTRL_XML(kth,kpv,pv,th) -!! INPUT ARGUMENT LIST: -!! KTH -!! TH -!! KPV -!! PV -!! -!! OUTPUT ARGUMENT LIST: -!! NONE - -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! COMMON - RQSTFLDGRB2 -!! CTLBLK -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : IBM -!! +!> This routine reads the control file in xml format specifying +!> field(s) to post, and save all the field information in +!> a datatype array PSET. +!> +!> @param[in] KTH +!> @param[in] TH +!> @param[in] KPV +!> @param[in] PV +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2012-01-27 | Jun Wang | Initial +!> 2015-03-10 | Lin Gan | Replace XML file with flat file implementation +!> 2019-10-30 | Bo Cui | Removw "GOTO" Statement +!> +!> @author J. Wang NCEP/EMC @date 2012-01-27 SUBROUTINE SET_OUTFLDS(kth,th,kpv,pv) ! diff --git a/sorc/ncep_post.fd/SLP_NMM.f b/sorc/ncep_post.fd/SLP_NMM.f deleted file mode 100644 index 9c8a3669e..000000000 --- a/sorc/ncep_post.fd/SLP_NMM.f +++ /dev/null @@ -1,411 +0,0 @@ - SUBROUTINE MEMSLP_NMM(TPRES,QPRES,FIPRES) -! -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBROUTINE: MEMSLP MEMBRANE SLP REDUCTION -! -! ABSTRACT: THIS ROUTINE COMPUTES THE SEA LEVEL PRESSURE -! REDUCTION USING THE MESINGER RELAXATION -! METHOD FOR SIGMA COORDINATES. -! A BY-PRODUCT IS THE -! SET OF VALUES FOR THE UNDERGROUND TEMPERATURES -! ON THE SPECIFIED PRESSURE LEVELS -! -! PROGRAM HISTORY LOG: -! 99-09-23 T BLACK - REWRITTEN FROM ROUTINE SLP (ETA -! COORDINATES) -! 02-07-26 H CHUANG - PARALLIZE AND MODIFIED FOR WRF A/C GRIDS -! ALSO REDUCE S.O.R. COEFF FROM 1.75 to 1.25 -! BECAUSE THERE WAS NUMERICAL INSTABILITY -! 02-08-21 H CHUANG - MODIFIED TO ALWAYS USE OLD TTV FOR RELAXATION -! SO THAT THERE WAS BIT REPRODUCIBILITY BETWEEN -! USING ONE AND MULTIPLE TASKS -! 13-12-06 H CHUANG - REMOVE EXTRA SMOOTHING OF SLP AT THE END -! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -! -! USAGE: CALL SLPSIG FROM SUBROUITNE ETA2P -! -! INPUT ARGUMENT LIST: -! PD - SFC PRESSURE MINUS PTOP -! FIS - SURFACE GEOPOTENTIAL -! T - TEMPERATURE -! Q - SPECIFIC HUMIDITY -! FI - GEOPOTENTIAL -! PT - TOP PRESSURE OF DOMAIN -! -! OUTPUT ARGUMENT LIST: -! PSLP - THE FINAL REDUCED SEA LEVEL PRESSURE ARRAY -! -! SUBPROGRAMS CALLED: -! UNIQUE: -! NONE -! -!----------------------------------------------------------------------- - use vrbls3d, only: pint, zint, t, q - use vrbls2d, only: pslp, fis - use masks, only: lmh - use params_mod, only: overrc, ad05, cft0, g, rd, d608, h1, kslpd - use ctlblk_mod, only: jsta, jend, spl, num_procs, mpi_comm_comp, lsmp1, jsta_m2, jend_m2,& - lm, jsta_m, jend_m, im, jsta_2l, jend_2u, im_jm, lsm, jm -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - INCLUDE "mpif.h" -!----------------------------------------------------------------------- - integer, PARAMETER :: NFILL=0,NRLX1=500,NRLX2=100 -!----------------------------------------------------------------------- - real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(in) :: QPRES - real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(inout) :: TPRES,FIPRES - REAL :: TTV(IM,JSTA_2L:JEND_2U),TNEW(IM,JSTA_2L:JEND_2U) & - ,SLPX(IM,JSTA_2L:JEND_2U) & - ,P1(IM,JSTA_2L:JEND_2U),HTM2D(IM,JSTA_2L:JEND_2U) - REAL :: HTMO(IM,JSTA_2L:JEND_2U,LSM) - real P2,GZ1,GZ2,TLYR,SPLL,PCHK,PSFC,SLOPE,TVRT,DIS,TINIT -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - INTEGER :: KMNTM(LSM),IMNT(IM_JM,LSM),JMNT(IM_JM,LSM) & - ,LMHO(IM,JSTA_2L:JEND_2U) - INTEGER :: IHE(JM),IHW(JM),IVE(JM),IVW(JM),IHS(JM),IHN(JM) - integer ii,jj,I,J,L,N,KM,KS,KP,KMN,KMM,KOUNT,LP,LLMH,LHMNT & - ,LMHIJ,LMAP1,LXXX,IERR,NRLX,IHH2 -!----------------------------------------------------------------------- - LOGICAL :: DONE(IM,JSTA_2L:JEND_2U) - logical, parameter :: debugprint = .false. -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!*** -!*** CALCULATE THE I-INDEX EAST-WEST INCREMENTS -!*** -! - ii=279 - jj=314 - DO J=1,JM - IHE(J)=MOD(J+1,2) - IHW(J)=IHE(J)-1 - ENDDO -! print*,'relaxation coeff= ',OVERRC -!----------------------------------------------------------------------- -!*** -!*** INITIALIZE ARRAYS. LOAD SLP ARRAY WITH SURFACE PRESSURE. -!*** -!$omp parallel do - DO J=JSTA,JEND - DO I=1,IM - LLMH=NINT(LMH(I,J)) - PSLP(I,J)=PINT(I,J,LLMH+1) - if(debugprint .and. i==ii .and. j==jj)print*,'Debug: FIS,IC for PSLP=' & - ,FIS(i,j),PSLP(I,J) - TTV(I,J)=0. - LMHO(I,J)=0 - DONE(I,J)=.FALSE. - ENDDO - ENDDO -! -!*** CALCULATE SEA LEVEL PRESSURE FOR PROFILES (AND POSSIBLY -!*** FOR POSTING BY POST PROCESSOR). -! -!-------------------------------------------------------------------- -!*** -!*** CREATE A 3-D "HEIGHT MASK" FOR THE SPECIFIED PRESSURE LEVELS -!*** (1 => ABOVE GROUND) AND A 2-D INDICATOR ARRAY THAT SAYS -!*** WHICH PRESSURE LEVEL IS THE LOWEST ONE ABOVE THE GROUND -!*** - DO 100 L=1,LSM - SPLL=SPL(L) -! - DO J=JSTA,JEND - DO I=1,IM - PSFC=PSLP(I,J) - PCHK=PSFC - IF(NFILL>0)THEN - PCHK=PINT(I,J,NINT(LMH(I,J))+1-NFILL) - ENDIF -! IF(SM(I,J)>0.5.AND.FIS(I,J)<1.)PCHK=PSLP(I,J) - IF(FIS(I,J)<1.)PCHK=PSLP(I,J) -! -! IF(SPLL1.AND.HTMO(I,J,L-1)>0.5)LMHO(I,J)=L-1 - ENDIF -! - IF(L==LSM.AND.HTMO(I,J,L)>0.5)LMHO(I,J)=LSM - if(debugprint .and. i==ii .and. j==jj)print*,'Debug: HTMO= ',HTMO(I,J,L) - ENDDO - ENDDO -! - 100 CONTINUE -! if(jj>=jsta.and.jj<=jend) -! +print*,'Debug: LMHO=',LMHO(ii,jj) -!-------------------------------------------------------------------- -!*** -!*** WE REACH THIS LINE IF WE WANT THE MESINGER ETA SLP REDUCTION -!*** BASED ON RELAXATION TEMPERATURES. THE FIRST STEP IS TO -!*** FIND THE HIGHEST LAYER CONTAINING MOUNTAINS. -!*** - loop210: DO L=LSM,1,-1 -! - DO J=JSTA,JEND - DO I=1,IM - IF(HTMO(I,J,L)<0.5) cycle loop210 - ENDDO - ENDDO -! - LHMNT=L+1 - exit loop210 - enddo loop210 - - if(debugprint)print*,'Debug in SLP: LHMNT=',LHMNT - if ( num_procs > 1 ) then - CALL MPI_ALLREDUCE & - (LHMNT,LXXX,1,MPI_INTEGER,MPI_MIN,MPI_COMM_COMP,IERR) - LHMNT = LXXX - end if - - IF(LHMNT==LSMP1)THEN - GO TO 325 - ENDIF - if(debugprint)print*,'Debug in SLP: LHMNT A ALLREDUCE=',LHMNT -!*** -!*** NOW GATHER THE ADDRESSES OF ALL THE UNDERGROUND POINTS. -!*** -!$omp parallel do private(kmn,kount) - DO 250 L=LHMNT,LSM - KMN=0 - KMNTM(L)=0 - KOUNT=0 - DO 240 J=JSTA_M2,JEND_M2 -! DO 240 J=JSTA_M,JEND_M - DO 240 I=2,IM-1 - KOUNT=KOUNT+1 - IMNT(KOUNT,L)=0 - JMNT(KOUNT,L)=0 - IF(HTMO(I,J,L)>0.5) CYCLE - KMN=KMN+1 - IMNT(KMN,L)=I - JMNT(KMN,L)=J - 240 CONTINUE - KMNTM(L)=KMN - 250 CONTINUE -! -! -!*** CREATE A TEMPORARY TV ARRAY, AND FOLLOW BY SEQUENTIAL -!*** OVERRELAXATION, DOING NRLX PASSES. -! -! IF(NTSD==1)THEN - NRLX=NRLX1 -! ELSE -! NRLX=NRLX2 -! ENDIF -! -!!$omp parallel do private(i,j,tinit,ttv) - DO 300 L=LHMNT,LSM -! - DO 270 J=JSTA,JEND - DO 270 I=1,IM - TTV(I,J)=TPRES(I,J,L) - IF(TTV(I,J)<150. .and. TTV(I,J)>325.0)print* & - ,'abnormal IC for T relaxation',i,j,TTV(I,J) - HTM2D(I,J)=HTMO(I,J,L) - 270 CONTINUE -! -!*** FOR GRID BOXES NEXT TO MOUNTAINS, COMPUTE TV TO USE AS -!*** BOUNDARY CONDITIONS FOR THE RELAXATION UNDERGROUND -! - CALL EXCH2(HTM2D(1,JSTA_2L)) !NEED TO EXCHANGE TWO ROW FOR E GRID - DO J=JSTA_M2,JEND_M2 - DO I=2,IM-1 - IF(HTM2D(I,J)>0.5.AND.HTM2D(I+IHW(J),J-1)*HTM2D(I+IHE(J),J-1) & - *HTM2D(I+IHW(J),J+1)*HTM2D(I+IHE(J),J+1) & - *HTM2D(I-1 ,J )*HTM2D(I+1 ,J ) & - *HTM2D(I ,J-2)*HTM2D(I ,J+2)<0.5)THEN -!HC MODIFICATION FOR C AND A GRIDS -!HC IF(HTM2D(I,J)>0.5.AND. -!HC 1 HTM2D(I-1,J)*HTM2D(I+1,J) -!HC 2 *HTM2D(I,J-1)*HTM2D(I,J+1) -!HC 3 *HTM2D(I-1,J-1)*HTM2D(I+1,J-1) -!HC 4 *HTM2D(I-1,J+1)*HTM2D(I+1,J+1)<0.5)THEN -! - TTV(I,J)=TPRES(I,J,L)*(1.+0.608*QPRES(I,J,L)) - ENDIF -! if(i==ii.and.j==jj)print*,'Debug:L,TTV B SMOO= ',l,TTV(I,J) - ENDDO - ENDDO -! - KMM=KMNTM(L) -! - DO 285 N=1,NRLX - CALL EXCH2(TTV(1,JSTA_2L)) -! print*,'Debug:L,KMM=',L,KMM - DO 280 KM=1,KMM - I=IMNT(KM,L) - J=JMNT(KM,L) - TINIT=TTV(I,J) - TNEW(I,J)=AD05*(4.*(TTV(I+IHW(J),J-1)+TTV(I+IHE(J),J-1) & - +TTV(I+IHW(J),J+1)+TTV(I+IHE(J),J+1)) & - +TTV(I-1,J) +TTV(I+1,J) & - +TTV(I,J-2) +TTV(I,J+2)) & - -CFT0*TTV(I,J) -!HC MODIFICATION FOR C AND A GRIDS -! eight point relaxation using old TTV -!HC TNEW(I,J)=AD05*(4.*(TTV(I-1,J)+TTV(I+1,J) -!HC 1 +TTV(I,J-1)+TTV(I,J+1)) -!HC 2 +TTV(I-1,J-1)+TTV(I+1,J-1) -!HC 3 +TTV(I-1,J+1)+TTV(I+1,J+1)) -!HC 4 -CFT0*TTV(I,J) -! -! if(i==ii.and.j==jj)print*,'Debug: L,TTV A S' -! 1,l,TTV(I,J),N -! 1,l,TNEW(I,J),N - 280 CONTINUE -! - DO KM=1,KMM - I=IMNT(KM,L) - J=JMNT(KM,L) - TTV(I,J)=TNEW(I,J) - END DO - 285 CONTINUE -! - DO 290 KM=1,KMM - I=IMNT(KM,L) - J=JMNT(KM,L) - TPRES(I,J,L)=TTV(I,J) - 290 CONTINUE - 300 CONTINUE -!---------------------------------------------------------------- -!*** -!*** CALCULATE THE SEA LEVEL PRESSURE AS PER THE NEW SCHEME. -!*** INTEGRATE THE HYDROSTATIC EQUATION DOWNWARD FROM THE -!*** GROUND THROUGH EACH OUTPUT PRESSURE LEVEL (WHERE TV -!*** IS NOW KNOWN) TO FIND GZ AT THE NEXT MIDPOINT BETWEEN -!*** PRESSURE LEVELS. WHEN GZ=0 IS REACHED, SOLVE FOR THE -!*** PRESSURE. -!*** -! -!*** COUNT THE POINTS WHERE SLP IS DONE BELOW EACH OUTPUT LEVEL -! - KOUNT=0 - DO J=JSTA,JEND - DO I=1,IM -! P1(I,J)=SPL(NINT(LMH(I,J))) -! DONE(I,J)=.FALSE. - IF(abs(FIS(I,J))<1.)THEN - PSLP(I,J)=PINT(I,J,NINT(LMH(I,J))+1) - DONE(I,J)=.TRUE. - KOUNT=KOUNT+1 - if(i==ii.and.j==jj)print*,'Debug:DONE,PSLP A S1=' & - ,done(i,j),PSLP(I,J) - ELSE IF(FIS(I,J)<-1.0) THEN - DO L=LM,1,-1 - IF(ZINT(I,J,L)>0.)THEN - PSLP(I,J)=PINT(I,J,L)/EXP(-ZINT(I,J,L)*G & - /(RD*T(I,J,L)*(Q(I,J,L)*D608+1.0))) - DONE(I,J)=.TRUE. - if(debugprint .and. i==ii.and.j==jj)print* & - ,'Debug:DONE,PINT,PSLP A S1=' & - ,done(i,j),PINT(I,J,L),PSLP(I,J) - EXIT - END IF - END DO - ENDIF - ENDDO - ENDDO -! - KMM=KMNTM(LSM) -!$omp parallel do private(gz1,gz2,i,j,lmap1,p1,p2),shared(pslp) - -LOOP320: DO KM=1,KMM - I=IMNT(KM,LSM) - J=JMNT(KM,LSM) - IF(DONE(I,J)) CYCLE - LMHIJ=LMHO(I,J) - GZ1=FIPRES(I,J,LMHIJ) - P1(I,J)=SPL(LMHIJ) -! - LMAP1=LMHIJ+1 - DO L=LMAP1,LSM - P2=SPL(L) - TLYR=0.5*(TPRES(I,J,L)+TPRES(I,J,L-1)) - GZ2=GZ1+RD*TLYR*ALOG(P1(I,J)/P2) - FIPRES(I,J,L)=GZ2 -! if(i==ii.and.j==jj)print*,'Debug:L,FI A S2=',L,GZ2 - IF(GZ2<=0.)THEN - PSLP(I,J)=P1(I,J)/EXP(-GZ1/(RD*TPRES(I,J,L-1))) -! if(i==ii.and.j==jj)print*,'Debug:PSLP A S2=',PSLP(I,J) - DONE(I,J)=.TRUE. - KOUNT=KOUNT+1 - CYCLE LOOP320 - ENDIF - P1(I,J)=P2 - GZ1=GZ2 - ENDDO -!HC EXPERIMENT - LP=LSM - SLOPE=-6.6E-4 - TLYR=TPRES(I,J,LP)-0.5*FIPRES(I,J,LP)*SLOPE - PSLP(I,J)=spl(lp)/EXP(-FIPRES(I,J,LP)/(RD*TLYR)) - DONE(I,J)=.TRUE. -! if(i==ii.and.j==jj)print*,'Debug:spl,FI,TLYR,PSLPA3=' & -! ,spl(lp),FIPRES(I,J,LP),TLYR,PSLP(I,J) -!HC EXPERIMENT -ENDDO LOOP320 -! -!*** WHEN SEA LEVEL IS BELOW THE LOWEST OUTPUT PRESSURE LEVEL, -!*** SOLVE THE HYDROSTATIC EQUATION BY CHOOSING A TEMPERATURE -!*** AT THE MIDPOINT OF THE LAYER BETWEEN THAT LOWEST PRESSURE -!*** LEVEL AND THE GROUND BY EXTRAPOLATING DOWNWARD FROM T ON -!*** THE LOWEST PRESSURE LEVEL USING THE DT/DFI BETWEEN THE -!*** LOWEST PRESSURE LEVEL AND THE ONE ABOVE IT. -! -! TOTAL=(IM-2)*(JM-4) -! -!HC DO 340 LP=LSM,1,-1 -! IF(KOUNT==TOTAL)GO TO 350 -!HC MODIFICATION FOR SMALL HILL HIGH PRESSURE SITUATION -!HC IF SURFACE PRESSURE IS CLOSER TO SEA LEVEL THAN LWOEST -!HC OUTPUT PRESSURE LEVEL, USE SURFACE PRESSURE TO DO EXTRAPOLATION - 325 CONTINUE - LP=LSM - DO 330 J=JSTA,JEND - DO 330 I=1,IM - if(debugprint .and. i==ii.and.j==jj)print*,'Debug: with 330 loop' - IF(DONE(I,J)) cycle - if(debugprint .and. i==ii.and.j==jj)print*,'Debug: still within 330 loop' -!HC Comment out the following line for situation with terrain -!HC at boundary (ie FIPRES<0) -!HC because they were not counted as undergound point for 8 pt -!HC relaxation -!HC IF(FIPRES(I,J,LP)<0.)GO TO 330 -! IF(FIPRES(I,J,LP)<0.)THEN -! DO LP=LSM,1,-1 -! IF (FIPRES(I,J) <= 0) - -! IF(FIPRES(I,J,LP)<0..OR.DONE(I,J))GO TO 330 -! SLOPE=(TPRES(I,J,LP)-TPRES(I,J,LP-1)) -! & /(FIPRES(I,J,LP)-FIPRES(I,J,LP-1)) - SLOPE=-6.6E-4 - IF(PINT(I,J,NINT(LMH(I,J))+1)>SPL(LP))THEN - LLMH=NINT(LMH(I,J)) - TVRT=T(I,J,LLMH)*(H1+D608*Q(I,J,LLMH)) - DIS=ZINT(I,J,LLMH+1)-ZINT(I,J,LLMH)+0.5*ZINT(I,J,LLMH+1) - TLYR=TVRT-DIS*G*SLOPE - PSLP(I,J)=PINT(I,J,LLMH+1)*EXP(ZINT(I,J,LLMH+1)*G/(RD*TLYR)) -! if(i==ii.and.j==jj)print*,'Debug:PSFC,zsfc,TLYR,PSLPA3=' -! 1,PINT(I,J,LLMH+1),ZINT(I,J,LLMH+1),TLYR,PSLP(I,J) - ELSE - TLYR=TPRES(I,J,LP)-0.5*FIPRES(I,J,LP)*SLOPE - PSLP(I,J)=spl(lp)/EXP(-FIPRES(I,J,LP)/(RD*TLYR)) - if(debugprint .and. i==ii.and.j==jj)print*,'Debug:spl,FI,TLYR,PSLPA3=' & - ,spl(lp),FIPRES(I,J,LP),TLYR,PSLP(I,J) - END IF - DONE(I,J)=.TRUE. - KOUNT=KOUNT+1 - 330 CONTINUE -!HC 340 CONTINUE -! - 350 CONTINUE -!---------------------------------------------------------------- - RETURN - END diff --git a/sorc/ncep_post.fd/SLP_new.f b/sorc/ncep_post.fd/SLP_new.f index e2aa20c0c..ef7a31d75 100644 --- a/sorc/ncep_post.fd/SLP_new.f +++ b/sorc/ncep_post.fd/SLP_new.f @@ -27,6 +27,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES) ! ARE COMMENTED OUT FOR NOW ! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT ! 21-07-26 W Meng - Restrict computation from undefined grids +! 21-07-07 J Meng - 2D DECOMPOSITION ! 21-09-25 W Meng - Further modification for restricting computation ! from undefined grids. ! @@ -54,7 +55,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES) use params_mod, only: overrc, ad05, cft0, g, rd, d608, h1, kslpd use ctlblk_mod, only: jend, jsta, spval, spl, num_procs, mpi_comm_comp, lsmp1, & jsta_m, jend_m, lm, im, jsta_2l, jend_2u, lsm, jm,& - im_jm + im_jm, iend, ista, ista_m, iend_m, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -63,29 +64,29 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES) integer,PARAMETER :: NFILL=0,NRLX1=500,NRLX2=100 real,parameter:: def_of_mountain=2.0 !----------------------------------------------------------------------- - real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(in) :: QPRES - real,dimension(IM,JSTA_2L:JEND_2U,LSM),intent(inout) :: TPRES,FIPRES - REAL :: TTV(IM,JSTA_2L:JEND_2U),TNEW(IM,JSTA_2L:JEND_2U) & - , P1(IM,JSTA_2L:JEND_2U),HTM2D(IM,JSTA_2L:JEND_2U) - REAL :: HTMO(IM,JSTA_2L:JEND_2U,LSM) + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM),intent(in) :: QPRES + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM),intent(inout) :: TPRES,FIPRES + REAL :: TTV(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),TNEW(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U) & + , P1(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),HTM2D(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U) + REAL :: HTMO(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LSM) real :: P2,TLYR,GZ1,GZ2,SPLL,PSFC,PCHK,SLOPE,TVRTC,DIS,TVRT,tem !----------------------------------------------------------------------- !----------------------------------------------------------------------- INTEGER :: KMNTM(LSM),IMNT(IM_JM,LSM),JMNT(IM_JM,LSM) & - , LMHO(IM,JSTA_2L:JEND_2U) + , LMHO(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U) INTEGER :: IHE(JM),IHW(JM),IVE(JM),IVW(JM),IHS(JM),IHN(JM) integer ii,jj,I,J,L,N,LLMH,KM,KS,IHH2,KOUNT,KMN,NRLX,LHMNT, & LMHIJ,LMAP1,KMM,LP,LXXX,IERR ! dong real a1,a2,a3,a4,a5,a6,a7,a8 !----------------------------------------------------------------------- - LOGICAL :: DONE(IM,JSTA_2L:JEND_2U) + LOGICAL :: DONE(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U) !----------------------------------------------------------------------- !*** !*** CALCULATE THE I-INDEX EAST-WEST INCREMENTS !*** ! - ii = IM/2 + ii = (IEND-ISTA)/2 jj = (JEND-JSTA)/2 DO J=1,JM IHE(J) = 1 @@ -102,7 +103,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES) !*** !$omp parallel do private(i,j,llmh) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LLMH = NINT(LMH(I,J)) PSLP(I,J) = PINT(I,J,LLMH+1) ! dong @@ -127,7 +128,7 @@ SUBROUTINE MEMSLP(TPRES,QPRES,FIPRES) ! !$omp parallel do private(j,i,psfc,pchk) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND HTMO(I,J,L)=1. if(PSLP(I,J)0) THEN - allocate(dwpsfc(im,jsta:jend)) + allocate(dwpsfc(ista:iend,jsta:jend)) CALL DEWPOINT(EVP,DWPSFC) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(029)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = DWPSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = DWPSFC(ii,jj) enddo enddo endif @@ -350,11 +358,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(076)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = RHSFC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = RHSFC(ii,jj) enddo enddo endif @@ -370,11 +379,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(762)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = QVG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = QVG(ii,jj) enddo enddo endif @@ -386,11 +396,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(760)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = QV2M(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = QV2M(ii,jj) enddo enddo endif @@ -401,11 +412,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(761)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = TSNOW(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = TSNOW(ii,jj) enddo enddo endif @@ -416,11 +428,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(724)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SNFDEN(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SNFDEN(ii,jj) enddo enddo endif @@ -454,11 +467,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(725)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SNDEPAC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SNDEPAC(ii,jj) enddo enddo endif @@ -480,11 +494,12 @@ SUBROUTINE SURFCE cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(116)) fld_info(cfld)%lvl=LVLSXML(L,IGET(116)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = STC(i,jj,l) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = STC(ii,jj,l) enddo enddo endif @@ -500,11 +515,12 @@ SUBROUTINE SURFCE cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(116)) fld_info(cfld)%lvl=LVLSXML(L,IGET(116)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = STC(i,jj,l) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = STC(ii,jj,l) enddo enddo endif @@ -521,11 +537,12 @@ SUBROUTINE SURFCE cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(117)) fld_info(cfld)%lvl=LVLSXML(L,IGET(117)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SMC(i,jj,l) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SMC(ii,jj,l) enddo enddo endif @@ -539,11 +556,12 @@ SUBROUTINE SURFCE cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(117)) fld_info(cfld)%lvl=LVLSXML(L,IGET(117)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SMC(i,jj,l) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SMC(ii,jj,l) enddo enddo endif @@ -558,11 +576,12 @@ SUBROUTINE SURFCE cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(225)) fld_info(cfld)%lvl=LVLSXML(L,IGET(225)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SH2O(i,jj,l) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SH2O(ii,jj,l) enddo enddo endif @@ -576,11 +595,12 @@ SUBROUTINE SURFCE cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(225)) fld_info(cfld)%lvl=LVLSXML(L,IGET(225)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SH2O(i,jj,l) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SH2O(ii,jj,l) enddo enddo endif @@ -596,11 +616,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(115)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = TG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = TG(ii,jj) enddo enddo endif @@ -608,11 +629,12 @@ SUBROUTINE SURFCE if(iget(571)>0.and.grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(571)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = TG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = TG(ii,jj) enddo enddo endif @@ -622,7 +644,7 @@ SUBROUTINE SURFCE IF (IGET(171)>0) THEN !!$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SMSTAV(I,J) /= SPVAL)THEN GRID1(I,J) = SMSTAV(I,J)*100. ELSE @@ -633,11 +655,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(171)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -647,7 +670,7 @@ SUBROUTINE SURFCE IF (IGET(036)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SMSTOT(I,J)/=SPVAL) THEN IF(SM(I,J) > SMALL .AND. SICE(I,J) < SMALL) THEN GRID1(I,J) = 1000.0 ! TEMPORY FIX TO MAKE SURE SMSTOT=1 FOR WATER @@ -662,11 +685,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(036)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -677,7 +701,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'RAPR') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J) else @@ -688,7 +712,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CMC(I,J) /= SPVAL) then GRID1(I,J) = CMC(I,J)*1000. else @@ -700,11 +724,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(118)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -716,11 +741,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(119)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SNO(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SNO(ii,jj) enddo enddo endiF @@ -731,7 +757,7 @@ SUBROUTINE SURFCE ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J) = 100.*SNOAVG(I,J) GRID1(I,J) = SNOAVG(I,J) if (SNOAVG(I,J) /= spval) GRID1(I,J) = 100.*SNOAVG(I,J) @@ -767,11 +793,12 @@ SUBROUTINE SURFCE fld_info(cfld)%tinvstat=IFHR-ID(18) ! fld_info(cfld)%ntrange=IFHR-ID(18) ! fld_info(cfld)%tinvstat=1 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -797,11 +824,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = PSFCAVG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = PSFCAVG(ii,jj) enddo enddo endif @@ -830,11 +858,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = T10AVG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = T10AVG(ii,jj) enddo enddo endif @@ -844,7 +873,7 @@ SUBROUTINE SURFCE IF ( IGET(244)>0 ) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SNONC(I,J) ENDDO ENDDO @@ -873,7 +902,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(244)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -881,7 +910,7 @@ SUBROUTINE SURFCE IF ( IGET(120)>0 ) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J)=PCTSNO(I,J) IF ( SNO(I,J) /= SPVAL ) THEN SNEQV = SNO(I,J) @@ -896,23 +925,24 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(120)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ENDIF ! ADD SNOW DEPTH IF ( IGET(224)>0 ) THEN - ii = im/2 + ii = (ista+iend)/2 jj = (jsta+jend)/2 ! GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SPVAL IF(SI(I,J) /= SPVAL) GRID1(I,J) = SI(I,J)*0.001 ! SI comes out of WRF in mm ENDDO @@ -921,11 +951,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(224)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -935,11 +966,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(242)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = POTEVP(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = POTEVP(ii,jj) enddo enddo endif @@ -949,11 +981,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(349)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = DZICE(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = DZICE(ii,jj) enddo enddo endif @@ -975,10 +1008,10 @@ SUBROUTINE SURFCE .OR.IGET(230)>0 .OR. IGET(231)>0 & .OR.IGET(232)>0 .OR. IGET(233)>0) THEN - allocate(smcdry(im,jsta:jend), & - smcmax(im,jsta:jend)) + allocate(smcdry(ista:iend,jsta:jend), & + smcmax(ista:iend,jsta:jend)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! ---------------------------------------------------------------------- ! IF(QWBS(I,J)>0.001)print*,'NONZERO QWBS',i,j,QWBS(I,J) ! IF(abs(SM(I,J)-0.)<1.0E-5)THEN @@ -1004,11 +1037,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(228)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = ECAN(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = ECAN(ii,jj) enddo enddo endiF @@ -1018,11 +1052,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(229)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = EDIR(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = EDIR(ii,jj) enddo enddo endif @@ -1032,7 +1067,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(230)) - datapd(1:im,1:jend-jsta+1,cfld) = ETRANS(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = ETRANS(ista:iend,jsta:jend) endif ENDIF @@ -1040,7 +1075,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(231)) - datapd(1:im,1:jend-jsta+1,cfld) = ESNOW(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = ESNOW(ista:iend,jsta:jend) endif ENDIF @@ -1048,11 +1083,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(232)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SMCDRY(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SMCDRY(ii,jj) enddo enddo endif @@ -1062,11 +1098,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(233)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = SMCMAX(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = SMCMAX(ii,jj) enddo enddo endif @@ -1086,11 +1123,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(512)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = acond(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = acond(ii,jj) enddo enddo endiF @@ -1124,11 +1162,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = avgECAN(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = avgECAN(ii,jj) enddo enddo endiF @@ -1162,11 +1201,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = avgEDIR(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = avgEDIR(ii,jj) enddo enddo endif @@ -1200,7 +1240,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld) = avgETRANS(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = avgETRANS(ista:iend,jsta:jend) endif ENDIF @@ -1232,7 +1272,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld) = avgESNOW(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = avgESNOW(ista:iend,jsta:jend) endif ENDIF @@ -1240,11 +1280,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(996)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = LANDFRAC(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = LANDFRAC(ii,jj) enddo enddo endif @@ -1254,11 +1295,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(997)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = PAHI(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = PAHI(ii,jj) enddo enddo endif @@ -1268,11 +1310,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(998)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = TWA(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = TWA(ii,jj) enddo enddo endif @@ -1281,7 +1324,7 @@ SUBROUTINE SURFCE IF ( IGET(999)>0 )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TECAN(I,J) ENDDO ENDDO @@ -1309,11 +1352,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(999)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1322,7 +1366,7 @@ SUBROUTINE SURFCE IF ( IGET(1000)>0 )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TETRAN(I,J) ENDDO ENDDO @@ -1350,11 +1394,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(1000)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1363,7 +1408,7 @@ SUBROUTINE SURFCE IF ( IGET(1001)>0 )THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TEDIR(I,J) ENDDO ENDDO @@ -1391,11 +1436,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(1001)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1409,7 +1455,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(PAHA(I,J)/=SPVAL)THEN GRID1(I,J)=-1.*PAHA(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -1444,7 +1490,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1461,12 +1507,12 @@ SUBROUTINE SURFCE (IGET(548)>0).OR.(IGET(739)>0).OR. & (IGET(771)>0)) THEN - if (.not. allocated(psfc)) allocate(psfc(im,jsta:jend)) + if (.not. allocated(psfc)) allocate(psfc(ista:iend,jsta:jend)) ! !HC COMPUTE SHELTER PRESSURE BECAUSE IT WAS NOT OUTPUT FROM WRF IF(MODELNAME == 'NCAR' .OR. MODELNAME=='RSM'.OR. MODELNAME=='RAPR')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TLOW = T(I,J,NINT(LMH(I,J))) PSFC(I,J) = PINT(I,J,NINT(LMH(I,J))+1) !May not have been set above PSHLTR(I,J) = PSFC(I,J)*EXP(-0.068283/TLOW) @@ -1483,7 +1529,7 @@ SUBROUTINE SURFCE IF (IGET(106)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J)=TSHLTR(I,J) !HC CONVERT FROM THETA TO T if(tshltr(i,j)/=spval)GRID1(I,J)=TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA @@ -1492,12 +1538,12 @@ SUBROUTINE SURFCE ! TSHLTR(I,J)=GRID1(I,J) ENDDO ENDDO -! print *,'2m tmp=',maxval(TSHLTR(1:im,jsta:jend)), & -! minval(TSHLTR(1:im,jsta:jend)),TSHLTR(1:3,jsta),'grd=',grid1(1:3,jsta) +! print *,'2m tmp=',maxval(TSHLTR(ista:iend,jsta:jend)), & +! minval(TSHLTR(ista:iend,jsta:jend)),TSHLTR(1:3,jsta),'grd=',grid1(1:3,jsta) if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(106)) - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -1505,21 +1551,21 @@ SUBROUTINE SURFCE IF (IGET(546)>0) THEN ! GRID1=spval ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! GRID1(I,J)=TSHLTR(I,J) ! ENDDO ! ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(546)) - datapd(1:im,1:jend-jsta+1,cfld) = TSHLTR(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = TSHLTR(ista:iend,jsta:jend) endif ENDIF ! ! SHELTER LEVEL SPECIFIC HUMIDITY. IF (IGET(112)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QSHLTR(I,J) ENDDO ENDDO @@ -1527,30 +1573,30 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(112)) - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif ENDIF ! GRID1 ! SHELTER MIXING RATIO. IF (IGET(414)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = MRSHLTR(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(414)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! SHELTER LEVEL DEWPOINT, DEWPOINT DEPRESSION AND SFC EQUIV POT TEMP. - allocate(p1d(im,jsta:jend), t1d(im,jsta:jend)) + allocate(p1d(ista:iend,jsta:jend), t1d(ista:iend,jsta:jend)) IF ((IGET(113)>0) .OR.(IGET(547)>0).OR.(IGET(548)>0)) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND !tgs The next 4 lines are GSD algorithm for Dew Point computation !tgs Results are very close to dew point computed in DEWPOINT subroutine @@ -1572,14 +1618,14 @@ SUBROUTINE SURFCE ENDIF ENDDO ENDDO - CALL DEWPOINT(EVP,EGRID1(1,jsta)) + CALL DEWPOINT(EVP,EGRID1(ista:iend,jsta:jend)) ! print *,' MAX DEWPOINT',maxval(egrid1) ! DEWPOINT IF (IGET(113)>0) THEN GRID1=spval if(MODELNAME=='RAPR')THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! DEWPOINT can't be higher than T2 t2=TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA if(qshltr(i,j)/=spval)GRID1(I,J)=min(EGRID1(I,J),T2) @@ -1587,7 +1633,7 @@ SUBROUTINE SURFCE ENDDO else DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(qshltr(i,j)/=spval) GRID1(I,J) = EGRID1(I,J) ENDDO ENDDO @@ -1595,7 +1641,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(113)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -1604,16 +1650,16 @@ SUBROUTINE SURFCE ! DEWPOINT at level 1 ------ p1d and t1d are undefined !! -- Moorthi IF (IGET(771)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND EVP(I,J)=P1D(I,J)*QVl1(I,J)/(EPS+ONEPS*QVl1(I,J)) EVP(I,J)=EVP(I,J)*D001 ENDDO ENDDO - CALL DEWPOINT(EVP,EGRID1(1,jsta)) + CALL DEWPOINT(EVP,EGRID1(ista:iend,jsta:jend)) ! print *,' MAX DEWPOINT at level 1',maxval(egrid1) GRID1=spval DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND !tgs 30 dec 2013 - 1st leel dewpoint can't be higher than 1-st level temperature if(qvl1(i,j)/=spval)GRID1(I,J) = min(EGRID1(I,J),T1D(I,J)) ENDDO @@ -1621,7 +1667,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(771)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !------------------------------------------------------------------------- @@ -1631,7 +1677,7 @@ SUBROUTINE SURFCE GRID1=SPVAL GRID2=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(TSHLTR(I,J)/=spval.and.PSHLTR(I,J)/=spval.and.QSHLTR(I,J)/=spval) then ! DEWPOINT DEPRESSION in GRID1 GRID1(i,j)=max(0.,TSHLTR(I,J)*(PSHLTR(I,J)*1.E-5)**CAPA-EGRID1(i,j)) @@ -1651,7 +1697,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(547)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -1659,7 +1705,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(548)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID2(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID2(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -1669,10 +1715,10 @@ SUBROUTINE SURFCE ! ! SHELTER LEVEL RELATIVE HUMIDITY AND APPARENT TEMPERATURE IF (IGET(114) > 0 .OR. IGET(808) > 0) THEN - allocate(q1d(im,jsta:jend)) + allocate(q1d(ista:iend,jsta:jend)) !$omp parallel do private(i,j,llmh) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(MODELNAME=='RAPR')THEN LLMH = NINT(LMH(I,J)) ! P1D(I,J)=PINT(I,J,LLMH+1) @@ -1686,12 +1732,12 @@ SUBROUTINE SURFCE ENDDO ENDDO - CALL CALRH(P1D,T1D,Q1D,EGRID1(1,jsta)) + CALL CALRH(P1D,T1D,Q1D,EGRID1(ista:iend,jsta:jend)) if (allocated(q1d)) deallocate(q1d) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(qshltr(i,j) /= spval)then GRID1(I,J) = EGRID1(I,J)*100. else @@ -1704,11 +1750,12 @@ SUBROUTINE SURFCE if(grib == 'grib2') then cfld = cfld+1 fld_info(cfld)%ifld = IAVBLFLD(IGET(114)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1718,7 +1765,7 @@ SUBROUTINE SURFCE GRID2=SPVAL !$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(T1D(I,J)/=spval.and.U10H(I,J)/=spval.and.V10H(I,J)0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! GRID1(I,J)=PSHLTR(I,J) ! ENDDO ! ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(138)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = PSHLTR(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = PSHLTR(ii,jj) enddo enddo endif @@ -1795,7 +1844,7 @@ SUBROUTINE SURFCE ! SHELTER LEVEL MAX TEMPERATURE. IF (IGET(345)>0) THEN ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! GRID1(I,J)=MAXTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1829,11 +1878,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%tinvstat=IFHR-ID(18) if(IFHR==0) fld_info(cfld)%tinvstat=0 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = MAXTSHLTR(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = MAXTSHLTR(ii,jj) enddo enddo endif @@ -1843,7 +1893,7 @@ SUBROUTINE SURFCE IF (IGET(346)>0) THEN !!$omp parallel do private(i,j) ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! GRID1(I,J) = MINTSHLTR(I,J) ! ENDDO ! ENDDO @@ -1875,11 +1925,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%tinvstat=IFHR-ID(18) if(IFHR==0) fld_info(cfld)%tinvstat=0 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = MINTSHLTR(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = MINTSHLTR(ii,jj) enddo enddo endif @@ -1889,7 +1940,7 @@ SUBROUTINE SURFCE IF (IGET(347)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(MAXRHSHLTR(I,J)/=spval) GRID1(I,J)=MAXRHSHLTR(I,J)*100. ENDDO ENDDO @@ -1927,11 +1978,12 @@ SUBROUTINE SURFCE if(IFHR==0) fld_info(cfld)%tinvstat=0 ! print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, & ! IFHR, ITMAXMIN -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -1941,7 +1993,7 @@ SUBROUTINE SURFCE IF (IGET(348)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(MINRHSHLTR(I,J)/=spval) GRID1(I,J)=MINRHSHLTR(I,J)*100. ENDDO ENDDO @@ -1977,11 +2029,12 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=ITMAXMIN fld_info(cfld)%tinvstat=IFHR-ID(18) if(IFHR==0) fld_info(cfld)%tinvstat=0 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2017,11 +2070,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=1 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = maxqshltr(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = maxqshltr(ii,jj) enddo enddo endif @@ -2056,11 +2110,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=1 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = minqshltr(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = minqshltr(ii,jj) enddo enddo endif @@ -2071,7 +2126,7 @@ SUBROUTINE SURFCE IF (IGET(739)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(T(I,J,LM)/=spval.and.PMID(I,J,LM)/=spval.and.SMOKE(I,J,LM,1)/=spval)& GRID1(I,J) = (1./RD)*(PMID(I,J,LM)/T(I,J,LM))*SMOKE(I,J,LM,1) ENDDO @@ -2079,7 +2134,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(739)) - datapd(1:im,1:jend-jsta+1,cfld) = GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -2092,7 +2147,7 @@ SUBROUTINE SURFCE IF ((IGET(064)>0).OR.(IGET(065)>0)) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = U10(I,J) GRID2(I,J) = V10(I,J) ENDDO @@ -2100,20 +2155,22 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(064)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(065)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -2122,7 +2179,7 @@ SUBROUTINE SURFCE IF (IGET(730)>0) THEN IFINCR = 5 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=SPDUV10MEAN(I,J) ENDDO ENDDO @@ -2138,7 +2195,7 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF !--- @@ -2146,7 +2203,7 @@ SUBROUTINE SURFCE IF (IGET(731)>0) THEN IFINCR = 5 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=U10MEAN(I,J) ENDDO ENDDO @@ -2161,14 +2218,14 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! GSD - Time-averaged V wind speed (forecast time labels will all be in minutes) IF (IGET(732)>0) THEN IFINCR = 5 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=V10MEAN(I,J) ENDDO ENDDO @@ -2183,14 +2240,14 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Time-averaged SWDOWN (forecast time labels will all be in minutes) IF (IGET(733)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWRADMEAN(I,J) ENDDO ENDDO @@ -2205,14 +2262,14 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! Time-averaged SWNORM (forecast time labels will all be in minutes) IF (IGET(734)>0 )THEN IFINCR = 15 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SWNORMMEAN(I,J) ENDDO ENDDO @@ -2227,7 +2284,7 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 endif - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -2242,7 +2299,7 @@ SUBROUTINE SURFCE ENDIF !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = U10MAX(I,J) GRID2(I,J) = V10MAX(I,J) ENDDO @@ -2256,11 +2313,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo cfld=cfld+1 @@ -2271,11 +2329,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -2288,18 +2347,19 @@ SUBROUTINE SURFCE IF (IGET(158)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=TH10(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(158)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2310,18 +2370,19 @@ SUBROUTINE SURFCE IF (IGET(505)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=T10M(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(505)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2332,18 +2393,19 @@ SUBROUTINE SURFCE IF (IGET(159)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Q10(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(159)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2356,7 +2418,7 @@ SUBROUTINE SURFCE IF (IGET(422)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = WSPD10MAX(I,J) ENDDO ENDDO @@ -2369,11 +2431,12 @@ SUBROUTINE SURFCE fld_info(cfld)%tinvstat=1 endif fld_info(cfld)%ntrange=1 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2384,7 +2447,7 @@ SUBROUTINE SURFCE IF (IGET(783)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = WSPD10UMAX(I,J) ENDDO ENDDO @@ -2397,11 +2460,12 @@ SUBROUTINE SURFCE fld_info(cfld)%tinvstat=1 endif fld_info(cfld)%ntrange=1 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2412,7 +2476,7 @@ SUBROUTINE SURFCE IF (IGET(784)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = WSPD10VMAX(I,J) ENDDO ENDDO @@ -2425,10 +2489,11 @@ SUBROUTINE SURFCE fld_info(cfld)%tinvstat=1 endif fld_info(cfld)%ntrange=1 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im + do i=1,iend-ista+1 + ii = ista+i-1 datapd(i,j,cfld) = GRID1(i,jj) enddo enddo @@ -2443,10 +2508,10 @@ SUBROUTINE SURFCE ! IF (IGET(588)>0) THEN - CALL CALVESSEL(ICEG(1,jsta)) + CALL CALVESSEL(ICEG(ista:iend,jsta:jend)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ICEG(I,J) ENDDO ENDDO @@ -2461,11 +2526,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2491,7 +2557,7 @@ SUBROUTINE SURFCE IF (IGET(172)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (PREC(I,J) <= PTHRESH .OR. SR(I,J)==spval) THEN GRID1(I,J) = -50. ELSE @@ -2502,11 +2568,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(172)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2520,7 +2587,7 @@ SUBROUTINE SURFCE GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(CPRATE(I,J)/=spval) GRID1(I,J) = CPRATE(I,J)*RDTPHS ! GRID1(I,J) = CUPPT(I,J)*RDTPHS ENDDO @@ -2528,11 +2595,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(249)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2546,7 +2614,7 @@ SUBROUTINE SURFCE GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(PREC(I,J)/=spval) then IF(MODELNAME /= 'RSM') THEN GRID1(I,J) = PREC(I,J)*RDTPHS*1000. @@ -2559,11 +2627,18 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(167)) -!$omp parallel do private(i,j,jj) + if(ITSRFC>0) then + fld_info(cfld)%ntrange=1 + else + fld_info(cfld)%ntrange=0 + endif + fld_info(cfld)%tinvstat=IFHR-ID(18) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2574,7 +2649,7 @@ SUBROUTINE SURFCE !-- PRATE_MAX in units of mm/h from NMMB history files GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(PRATE_MAX(I,J)/=spval) GRID1(I,J)=PRATE_MAX(I,J)*SEC2HR ENDDO ENDDO @@ -2588,11 +2663,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2603,7 +2679,7 @@ SUBROUTINE SURFCE !-- FPRATE_MAX in units of mm/h from NMMB history files GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(FPRATE_MAX(I,J)/=spval) GRID1(I,J)=FPRATE_MAX(I,J)*SEC2HR ENDDO ENDDO @@ -2617,11 +2693,12 @@ SUBROUTINE SURFCE else fld_info(cfld)%ntrange=0 endif -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2654,7 +2731,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(AVGCPRATE(I,J)/=spval) GRID1(I,J) = AVGCPRATE(I,J)*RDTPHS ENDDO ENDDO @@ -2673,11 +2750,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2711,7 +2789,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(avgprec(i,j)/=spval) GRID1(I,J) = AVGPREC(I,J)*RDTPHS ENDDO ENDDO @@ -2727,11 +2805,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2762,7 +2841,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGPREC(I,J) < SPVAL)THEN GRID1(I,J) = AVGPREC(I,J)*FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 ELSE @@ -2772,7 +2851,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! IF(AVGPREC_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2783,7 +2862,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ACPREC(I,J) < SPVAL)THEN GRID1(I,J) = ACPREC(I,J)*1000. ELSE @@ -2805,11 +2884,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) ! print*,'id(18),tinvstat in apcp= ',ID(18),fld_info(cfld)%tinvstat -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo !! add continuous bucket @@ -2856,7 +2936,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGPREC_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -2874,11 +2954,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR ! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -2911,7 +2992,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCPRATE(I,J) < SPVAL)THEN GRID1(I,J) = AVGCPRATE(I,J)* & FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 @@ -2922,7 +3003,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ! ELSE @@ -2933,7 +3014,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(CUPREC(I,J) < SPVAL)THEN GRID1(I,J) = CUPREC(I,J)*1000. ELSE @@ -2948,11 +3029,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(033)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo !! add continuous bucket @@ -2998,7 +3080,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2 ELSE @@ -3015,11 +3097,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(418)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -3053,7 +3136,7 @@ SUBROUTINE SURFCE IF(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCPRATE(I,J) < SPVAL .AND. AVGPREC(I,J) < SPVAL) then GRID1(I,J) = ( AVGPREC(I,J) - AVGCPRATE(I,J) ) * & FLOAT(ID(19)-ID(18))*3600.*1000./DTQ2 @@ -3064,7 +3147,7 @@ SUBROUTINE SURFCE ENDDO !! Chuang 3/29/2018: add continuous bucket ! DO J=JSTA,JEND -! DO I=1,IM +! DO I=ISTA,IEND ! IF(AVGCPRATE_CONT(I,J) < SPVAL .AND. AVGPREC_CONT(I,J) < SPVAL)THEN ! GRID2(I,J) = (AVGPREC_CONT(I,J) - AVGCPRATE_CONT(I,J)) & ! *FLOAT(IFHR)*3600.*1000./DTQ2 @@ -3076,7 +3159,7 @@ SUBROUTINE SURFCE ELSE !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ANCPRC(I,J)*1000. ENDDO ENDDO @@ -3087,11 +3170,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(034)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo !! add continuous bucket @@ -3102,8 +3186,9 @@ SUBROUTINE SURFCE ! fld_info(cfld)%tinvstat=IFHR ! do j=1,jend-jsta+1 ! jj = jsta+j-1 -! do i=1,im -! datapd(i,j,cfld) = GRID2(i,jj) +! do i=1,iend-ista+1 +! ii = ista+1-1 +! datapd(i,j,cfld) = GRID2(ii,jj) ! enddo ! enddo ! endif @@ -3137,7 +3222,7 @@ SUBROUTINE SURFCE ! Chuang 3/29/2018: add continuous bucket !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(AVGCPRATE_CONT(I,J) < SPVAL .AND. AVGPREC_CONT(I,J) < SPVAL)THEN GRID2(I,J) = (AVGPREC_CONT(I,J) - AVGCPRATE_CONT(I,J)) & *FLOAT(IFHR)*3600.*1000./DTQ2 @@ -3155,11 +3240,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(419)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -3171,7 +3257,7 @@ SUBROUTINE SURFCE GRID1=SPVAL !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(LSPA(I,J)<=-1.0E-6)THEN if(ACPREC(I,J)/=spval) GRID1(I,J) = ACPREC(I,J)*1000 ELSE @@ -3206,11 +3292,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(256)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3220,7 +3307,7 @@ SUBROUTINE SURFCE IF (IGET(035)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J) = ACSNOW(I,J)*1000. GRID1(I,J) = ACSNOW(I,J) ENDDO @@ -3251,11 +3338,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(035)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3265,7 +3353,7 @@ SUBROUTINE SURFCE IF (IGET(746)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ACGRAUP(I,J) ENDDO ENDDO @@ -3295,11 +3383,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(746)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3309,7 +3398,7 @@ SUBROUTINE SURFCE IF (IGET(782)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ACFRAIN(I,J) ENDDO ENDDO @@ -3339,11 +3428,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(782)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3353,7 +3443,7 @@ SUBROUTINE SURFCE IF (IGET(121)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J) = ACSNOM(I,J)*1000. GRID1(I,J) = ACSNOM(I,J) ENDDO @@ -3384,11 +3474,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(121)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3398,7 +3489,7 @@ SUBROUTINE SURFCE IF (IGET(405)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SNOWFALL(I,J) ENDDO ENDDO @@ -3429,11 +3520,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(405)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3443,7 +3535,7 @@ SUBROUTINE SURFCE IF (IGET(122)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J) = SSROFF(I,J)*1000. GRID1(I,J) = SSROFF(I,J) ENDDO @@ -3482,11 +3574,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(122)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3496,7 +3589,7 @@ SUBROUTINE SURFCE IF (IGET(123)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! GRID1(I,J) = BGROFF(I,J)*1000. GRID1(I,J) = BGROFF(I,J) ENDDO @@ -3535,11 +3628,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(123)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3549,7 +3643,7 @@ SUBROUTINE SURFCE IF (IGET(343)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RUNOFF(I,J) ENDDO ENDDO @@ -3582,11 +3676,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(343)) fld_info(cfld)%ntrange=1 fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3597,7 +3692,7 @@ SUBROUTINE SURFCE IF (IGET(434)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3644,11 +3739,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3659,7 +3755,7 @@ SUBROUTINE SURFCE IF (IGET(435)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3713,11 +3809,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3727,7 +3824,7 @@ SUBROUTINE SURFCE IF (IGET(436)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -3774,11 +3871,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3788,7 +3886,7 @@ SUBROUTINE SURFCE IF (IGET(437)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SNOW_BUCKET(I,J) ENDDO ENDDO @@ -3832,11 +3930,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -3846,7 +3945,7 @@ SUBROUTINE SURFCE IF (IGET(775)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = GRAUP_BUCKET(I,J) ENDDO ENDDO @@ -3890,11 +3989,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4038,7 +4138,7 @@ SUBROUTINE SURFCE IF (IGET(526)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -4058,11 +4158,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4071,7 +4172,7 @@ SUBROUTINE SURFCE IF (IGET(527)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -4091,11 +4192,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4104,7 +4206,7 @@ SUBROUTINE SURFCE IF (IGET(528)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -4124,11 +4226,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4137,7 +4240,7 @@ SUBROUTINE SURFCE IF (IGET(529)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -4158,11 +4261,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4171,7 +4275,7 @@ SUBROUTINE SURFCE IF (IGET(530)>0.) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR == 0 .AND. IFMIN == 0) THEN GRID1(I,J) = 0.0 ELSE @@ -4192,11 +4296,12 @@ SUBROUTINE SURFCE endif fld_info(cfld)%ntrange=1 end if -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4206,9 +4311,9 @@ SUBROUTINE SURFCE ! print *,'in surfce,iget(160)=',iget(160),'iget(247)=',iget(247) IF (IGET(160)>0 .OR.(IGET(247)>0)) THEN - allocate(sleet(im,jsta:jend,nalg), rain(im,jsta:jend,nalg), & - freezr(im,jsta:jend,nalg), snow(im,jsta:jend,nalg)) - allocate(zwet(im,jsta:jend)) + allocate(sleet(ista:iend,jsta:jend,nalg), rain(ista:iend,jsta:jend,nalg), & + freezr(ista:iend,jsta:jend,nalg), snow(ista:iend,jsta:jend,nalg)) + allocate(zwet(ista:iend,jsta:jend)) CALL CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,PREC,ZINT,IWX1,ZWET) ! write(0,*)' after first CALWXT_POST' @@ -4216,7 +4321,7 @@ SUBROUTINE SURFCE IF (IGET(160)>0) THEN !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ZWET(I,J)0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = ZWET(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(247)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4267,7 +4373,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX = IWX1(I,J) SNOW(I,J,2) = MOD(IWX,2) SLEET(I,J,2) = MOD(IWX,4)/2 @@ -4280,7 +4386,7 @@ SUBROUTINE SURFCE ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+ & & MOD(IFHR*60+IFMIN,44641)+4357 ! write(0,*)'in SURFCE,me=',me,'bef 1st CALWXT_BOURG_POST iseed=',iseed - CALL CALWXT_BOURG_POST(IM,JM,JSTA_2L,JEND_2U,JSTA,JEND,LM,LP1,& + CALL CALWXT_BOURG_POST(IM,ISTA_2L,IEND_2U,ISTA,IEND,JM,JSTA_2L,JEND_2U,JSTA,JEND,LM,LP1,& & ISEED,G,PTHRESH, & & T,Q,PMID,PINT,LMH,PREC,ZINT,IWX1,me) ! write(0,*)'in SURFCE,me=',me,'aft 1st CALWXT_BOURG_POST' @@ -4290,7 +4396,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX = IWX1(I,J) SNOW(I,J,3) = MOD(IWX,2) SLEET(I,J,3) = MOD(IWX,4)/2 @@ -4306,7 +4412,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX = IWX1(I,J) SNOW(I,J,4) = MOD(IWX,2) SLEET(I,J,4) = MOD(IWX,4)/2 @@ -4322,7 +4428,7 @@ SUBROUTINE SURFCE else !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX1(I,J) = 0 ENDDO ENDDO @@ -4332,7 +4438,7 @@ SUBROUTINE SURFCE ! !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IWX = IWX1(I,J) SNOW(I,J,5) = MOD(IWX,2) SLEET(I,J,5) = MOD(IWX,4)/2 @@ -4341,27 +4447,28 @@ SUBROUTINE SURFCE ENDDO ENDDO - allocate(domr(im,jsta:jend), doms(im,jsta:jend), & - domzr(im,jsta:jend), domip(im,jsta:jend)) - CALL CALWXT_DOMINANT_POST(PREC(1,jsta_2l),RAIN,FREEZR,SLEET,SNOW, & + allocate(domr(ista:iend,jsta:jend), doms(ista:iend,jsta:jend), & + domzr(ista:iend,jsta:jend), domip(ista:iend,jsta:jend)) + CALL CALWXT_DOMINANT_POST(PREC(ista_2l,jsta_2l),RAIN,FREEZR,SLEET,SNOW, & DOMR,DOMZR,DOMIP,DOMS) ! if ( me==0) print *,'after CALWXT_DOMINANT, no avrg' ! SNOW. grid1 = spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(prec(i,j) /= spval) GRID1(I,J) = DOMS(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(551)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4369,18 +4476,19 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(prec(i,j)/=spval) GRID1(I,J) = DOMIP(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(552)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4388,7 +4496,7 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! if (DOMZR(I,J) == 1) THEN ! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1) ! print *, 'aha ', I, J, PSFC(I,J) @@ -4401,11 +4509,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(553)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4413,18 +4522,19 @@ SUBROUTINE SURFCE grid1=spval !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(prec(i,j)/=spval)GRID1(I,J) = DOMR(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(160)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -4434,16 +4544,16 @@ SUBROUTINE SURFCE ! TIME AVERAGED PRECIPITATION TYPE. IF (IGET(317)>0) THEN - if (.not. allocated(sleet)) allocate(sleet(im,jsta:jend,nalg)) - if (.not. allocated(rain)) allocate(rain(im,jsta:jend,nalg)) - if (.not. allocated(freezr)) allocate(freezr(im,jsta:jend,nalg)) - if (.not. allocated(snow)) allocate(snow(im,jsta:jend,nalg)) - if (.not. allocated(zwet)) allocate(zwet(im,jsta:jend)) + if (.not. allocated(sleet)) allocate(sleet(ista:iend,jsta:jend,nalg)) + if (.not. allocated(rain)) allocate(rain(ista:iend,jsta:jend,nalg)) + if (.not. allocated(freezr)) allocate(freezr(ista:iend,jsta:jend,nalg)) + if (.not. allocated(snow)) allocate(snow(ista:iend,jsta:jend,nalg)) + if (.not. allocated(zwet)) allocate(zwet(ista:iend,jsta:jend)) CALL CALWXT_POST(T,Q,PMID,PINT,HTM,LMH,AVGPREC,ZINT,IWX1,ZWET) !$omp parallel do private(i,j,iwx) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ZWET(I,J)0 .or. IGET(559)>0 .or. & IGET(560)>0 .or. IGET(561)>0) THEN - if (.not. allocated(domr)) allocate(domr(im,jsta:jend)) - if (.not. allocated(doms)) allocate(doms(im,jsta:jend)) - if (.not. allocated(domzr)) allocate(domzr(im,jsta:jend)) - if (.not. allocated(domip)) allocate(domip(im,jsta:jend)) + if (.not. allocated(domr)) allocate(domr(ista:iend,jsta:jend)) + if (.not. allocated(doms)) allocate(doms(ista:iend,jsta:jend)) + if (.not. allocated(domzr)) allocate(domzr(ista:iend,jsta:jend)) + if (.not. allocated(domip)) allocate(domip(ista:iend,jsta:jend)) !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DOMS(I,J) = 0. !-- snow DOMR(I,J) = 0. !-- rain DOMZR(I,J) = 0. !-- freezing rain @@ -4790,7 +4904,7 @@ SUBROUTINE SURFCE ENDDO DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND !-- TOTPRCP is total 1-hour accumulated precipitation in [m] totprcp = (RAINC_BUCKET(I,J) + RAINNC_BUCKET(I,J))*1.e-3 snowratio = 0.0 @@ -4911,7 +5025,7 @@ SUBROUTINE SURFCE maxval(snow_bucket)*0.1,minval(snow_bucket)*0.1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND do icat=1,10 if (snow_bucket(i,j)*0.1<0.1*float(icat).and. & snow_bucket(i,j)*0.1>0.1*float(icat-1)) then @@ -4928,7 +5042,7 @@ SUBROUTINE SURFCE icnt_snow_rain_mixed = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if (DOMR(i,j)==1 .and. DOMS(i,j)==1) then icnt_snow_rain_mixed = icnt_snow_rain_mixed + 1 endif @@ -4942,25 +5056,26 @@ SUBROUTINE SURFCE ! SNOW. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=DOMS(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(559)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ! ICE PELLETS. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DOMIP(I,J) ! if (DOMIP(I,J) == 1) THEN ! print *, 'ICE PELLETS at I,J ', I, J @@ -4970,18 +5085,19 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(560)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ! FREEZING RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! if (DOMZR(I,J) == 1) THEN ! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1) ! print *, 'FREEZING RAIN AT I,J ', I, J, PSFC(I,J) @@ -4992,29 +5108,31 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(561)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif ! RAIN. !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = DOMR(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(407)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -5043,7 +5161,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SFCLHX(I,J)/=SPVAL)THEN GRID1(I,J)=-1.*SFCLHX(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -5078,7 +5196,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif END IF ENDIF @@ -5096,7 +5214,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SFCSHX(I,J)/=SPVAL)THEN GRID1(I,J) = -1.* SFCSHX(I,J)*RRNUM !change the sign to conform with Grib ELSE @@ -5132,7 +5250,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5150,7 +5268,7 @@ SUBROUTINE SURFCE ENDIF GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(SUBSHX(I,J)/=spval) GRID1(I,J) = SUBSHX(I,J)*RRNUM ENDDO ENDDO @@ -5182,7 +5300,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5200,7 +5318,7 @@ SUBROUTINE SURFCE ENDIF GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(SNOPCX(I,J)/=spval) GRID1(I,J) = SNOPCX(I,J)*RRNUM ENDDO ENDDO @@ -5232,7 +5350,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5249,7 +5367,7 @@ SUBROUTINE SURFCE RRNUM=0. ENDIF DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(SFCUVX(I,J)/=SPVAL)THEN GRID1(I,J) = SFCUVX(I,J)*RRNUM ELSE @@ -5285,7 +5403,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5303,7 +5421,7 @@ SUBROUTINE SURFCE ENDIF GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(SFCUX(I,J)/=spval) GRID1(I,J) = SFCUX(I,J)*RRNUM ENDDO ENDDO @@ -5335,7 +5453,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5353,7 +5471,7 @@ SUBROUTINE SURFCE ENDIF GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(SFCVX(I,J)/=spval) GRID1(I,J) = SFCVX(I,J)*RRNUM ENDDO ENDDO @@ -5385,7 +5503,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5393,7 +5511,7 @@ SUBROUTINE SURFCE IF (IGET(047)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(SFCEVP(I,J)/=spval) GRID1(I,J) = SFCEVP(I,J)*1000. ENDDO ENDDO @@ -5427,7 +5545,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -5436,7 +5554,7 @@ SUBROUTINE SURFCE IF (IGET(137)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(POTEVP(I,J)/=spval) GRID1(I,J) = POTEVP(I,J)*1000. ENDDO ENDDO @@ -5470,35 +5588,35 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! ROUGHNESS LENGTH. IF (IGET(044)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = Z0(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(044)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! FRICTION VELOCITY. IF (IGET(045)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = USTAR(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(045)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5506,41 +5624,41 @@ SUBROUTINE SURFCE ! dong add missing value for cd IF (IGET(132)>0) THEN GRID1=spval - CALL CALDRG(EGRID1(1,jsta_2l)) + CALL CALDRG(EGRID1(ista_2l:iend_2u,jsta_2l:jend_2u)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(USTAR(I,J) < spval) GRID1(I,J)=EGRID1(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(132)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF write_cd: IF(IGET(922)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=CD10(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(922)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF write_cd write_ch: IF(IGET(923)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=CH10(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(923)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF write_ch ! @@ -5550,14 +5668,14 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE U COMPONENT WIND STRESS. IF (IGET(900)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=MDLTAUX(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(900)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -5565,14 +5683,14 @@ SUBROUTINE SURFCE ! MODEL OUTPUT SURFACE V COMPONENT WIND STRESS IF (IGET(901)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=MDLTAUY(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(901)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -5582,13 +5700,13 @@ SUBROUTINE SURFCE ! dong add missing value GRID1 = spval IF(MODELNAME /= 'FV3R') & - CALL CALTAU(EGRID1(1,jsta),EGRID2(1,jsta)) + CALL CALTAU(EGRID1(ista:iend,jsta:jend),EGRID2(ista:iend,jsta:jend)) ! ! SURFACE U COMPONENT WIND STRESS. ! dong for FV3, directly use model output IF (IGET(133)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCUXI(I,J) ELSE @@ -5600,14 +5718,14 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(133)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! SURFACE V COMPONENT WIND STRESS IF (IGET(134)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(MODELNAME == 'FV3R') THEN GRID1(I,J)=SFCVXI(I,J) ELSE @@ -5618,7 +5736,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(134)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -5629,7 +5747,7 @@ SUBROUTINE SURFCE ! GRAVITY U COMPONENT WIND STRESS. IF (IGET(315)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = GTAUX(I,J) ENDDO ENDDO @@ -5660,14 +5778,14 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=1 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! SURFACE V COMPONENT WIND STRESS IF (IGET(316)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=GTAUY(I,J) ENDDO ENDDO @@ -5698,7 +5816,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=1 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -5711,14 +5829,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = TWBS(I,J) ENDDO ENDDO ELSE !4omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(TWBS(I,J) < spval) GRID1(I,J) = -TWBS(I,J) ENDDO ENDDO @@ -5726,7 +5844,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(154)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5738,14 +5856,14 @@ SUBROUTINE SURFCE MODELNAME=='RAPR')THEN !4omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = QWBS(I,J) ENDDO ENDDO ELSE !4omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(QWBS(I,J) < spval) GRID1(I,J) = -QWBS(I,J) ENDDO ENDDO @@ -5753,21 +5871,21 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(155)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! SURFACE EXCHANGE COEFF IF (IGET(169)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=SFCEXC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(169)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5775,14 +5893,14 @@ SUBROUTINE SURFCE IF (IGET(170)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(VEGFRC(I,J)/=spval) GRID1(I,J)=VEGFRC(I,J)*100. ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(170)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -5791,14 +5909,14 @@ SUBROUTINE SURFCE IF (IGET(726)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(shdmin(I,J)/=spval) GRID1(I,J)=shdmin(I,J)*100. ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(726)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5806,14 +5924,14 @@ SUBROUTINE SURFCE IF (IGET(729)>0) THEN GRID1=SPVAL DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND if(shdmax(I,J)/=spval) GRID1(I,J)=shdmax(I,J)*100. ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(729)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! @@ -5823,7 +5941,7 @@ SUBROUTINE SURFCE IF (iSF_SURFACE_PHYSICS == 2 .OR. MODELNAME=='RAPR') THEN IF (IGET(254)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (MODELNAME=='RAPR')THEN GRID1(I,J)=LAI(I,J) ELSE @@ -5834,7 +5952,7 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(254)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ENDIF @@ -5843,54 +5961,54 @@ SUBROUTINE SURFCE ! INSTANTANEOUS GROUND HEAT FLUX IF (IGET(152)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=GRNFLX(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(152)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! VEGETATION TYPE IF (IGET(218)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FLOAT(IVGTYP(I,J)) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(218)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! SOIL TYPE IF (IGET(219)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FLOAT(ISLTYP(I,J)) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(219)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! SLOPE TYPE IF (IGET(223)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FLOAT(ISLOPE(I,J)) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(223)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! if (me==0)print*,'starting computing canopy conductance' @@ -5906,10 +6024,10 @@ SUBROUTINE SURFCE & .OR. IGET(241)>0 ) THEN IF (iSF_SURFACE_PHYSICS == 2) THEN !NSOIL == 4 ! if(me==0)print*,'starting computing canopy conductance' - allocate(rsmin(im,jsta:jend), smcref(im,jsta:jend), gc(im,jsta:jend), & - rcq(im,jsta:jend), rct(im,jsta:jend), rcsoil(im,jsta:jend), rcs(im,jsta:jend)) + allocate(rsmin(ista:iend,jsta:jend), smcref(ista:iend,jsta:jend), gc(ista:iend,jsta:jend), & + rcq(ista:iend,jsta:jend), rct(ista:iend,jsta:jend), rcsoil(ista:iend,jsta:jend), rcs(ista:iend,jsta:jend)) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF( (abs(SM(I,J)-0.) < 1.0E-5) .AND. & & (abs(SICE(I,J)-0.) < 1.0E-5) ) THEN IF(CZMEAN(I,J)>1.E-6) THEN @@ -5952,118 +6070,118 @@ SUBROUTINE SURFCE IF (IGET(220)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = GC(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(220)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(234)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RSMIN(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(234)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(235)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = FLOAT(NROOTS(I,J)) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(235)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(236)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SMCWLT(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(236)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(237)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = SMCREF(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(237)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(238)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RCS(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(238)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(239)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RCT(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(239)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(240)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RCQ(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(240)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF IF (IGET(241)>0 )THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = RCSOIL(I,J) ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(241)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -6085,7 +6203,7 @@ SUBROUTINE SURFCE IF(IGET(236)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = smcwlt(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = WLTSMC(isltyp(i,j)) @@ -6097,11 +6215,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(236)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -6110,7 +6229,7 @@ SUBROUTINE SURFCE IF(IGET(397)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = fieldcapa(i,j) ! IF(isltyp(i,j)/=0)THEN ! GRID1(I,J) = REFSMC(isltyp(i,j)) @@ -6122,11 +6241,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(397)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -6135,7 +6255,7 @@ SUBROUTINE SURFCE IF(IGET(396)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = suntime(i,j) ENDDO ENDDO @@ -6166,11 +6286,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -6179,7 +6300,7 @@ SUBROUTINE SURFCE IF(IGET(517)>0)THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = avgpotevp(i,j) ENDDO ENDDO @@ -6210,11 +6331,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -6226,21 +6348,21 @@ SUBROUTINE SURFCE IF (IGET(282)>0) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PT ENDDO ENDDO if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(282)) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(283)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=PDTOP ENDDO ENDDO @@ -6257,14 +6379,14 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(283)) fld_info(cfld)%lvl1=1 fld_info(cfld)%lvl2=L - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! ! SIGMA PRESSURE THICKNESS REQUESTED BY CMAQ IF (IGET(273)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=PD(I,J) ENDDO ENDDO @@ -6281,7 +6403,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(273)) fld_info(cfld)%lvl1=L fld_info(cfld)%lvl2=LM+1 - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -6289,7 +6411,7 @@ SUBROUTINE SURFCE ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ IF (IGET(503)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AKHSAVG(I,J) ENDDO ENDDO @@ -6311,14 +6433,14 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF ! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ IF (IGET(504)>0) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J)=AKMSAVG(I,J) ENDDO ENDDO @@ -6340,7 +6462,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ntrange=0 endif fld_info(cfld)%tinvstat=IFHR-ID(18) - datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend) + datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=GRID1(ista:iend,jsta:jend) endif ENDIF @@ -6354,7 +6476,8 @@ subroutine qpf_comp(igetfld,compfile,fcst) ! compfile: file name for reference grid. ! fcst: forecast length in hours. use ctlblk_mod, only: SPVAL,JSTA,JEND,IM,DTQ2,IFHR,IFMIN,TPREC,GRIB, & - MODELNAME,JM,CFLD,DATAPD,FLD_INFO,JSTA_2L,JEND_2U + MODELNAME,JM,CFLD,DATAPD,FLD_INFO,JSTA_2L,JEND_2U,& + ISTA,IEND,ISTA_2L,IEND_2U use rqstfld_mod, only: IGET, ID, LVLS, IAVBLFLD use grib2_module, only: read_grib2_head, read_grib2_sngle use vrbls2d, only: AVGPREC, AVGPREC_CONT @@ -6373,7 +6496,7 @@ subroutine qpf_comp(igetfld,compfile,fcst) logical :: file_exists - integer :: i, j, k, jj + integer :: i, j, k, ii, jj ! Read in reference grid. INQUIRE(FILE=compfile, EXIST=file_exists) @@ -6416,7 +6539,7 @@ subroutine qpf_comp(igetfld,compfile,fcst) ! !$omp parallel do private(i,j) IF (file_exists) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (IFHR .EQ. 0 .OR. fcst .EQ. 0) THEN outgrid(I,J) = 0.0 ELSE IF (mscValue(I,J) .LE. 0.0) THEN @@ -6468,11 +6591,12 @@ subroutine qpf_comp(igetfld,compfile,fcst) fld_info(cfld)%ifld=IAVBLFLD(IGET(igetfld)) fld_info(cfld)%ntrange=trange fld_info(cfld)%tinvstat=invstat -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = outgrid(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = outgrid(ii,jj) enddo enddo endif diff --git a/sorc/ncep_post.fd/TRPAUS.f b/sorc/ncep_post.fd/TRPAUS.f index 2523717b5..24a27d71d 100644 --- a/sorc/ncep_post.fd/TRPAUS.f +++ b/sorc/ncep_post.fd/TRPAUS.f @@ -1,53 +1,37 @@ !> @file -! -!> SUBPROGRAM: TRPAUS COMPUTE TROPOPAUSE DATA. -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES TROPOPAUSE DATA. AT EACH MASS -!! POINT A SURFACE UP SEARCH IS MADE FOR THE FIRST -!! OCCURRENCE OF A THREE LAYER MEAN LAPSE RATE LESS THAN -!! OR EQUAL TO A CRITICAL LAPSE RATE. THIS CRITCAL LAPSE -!! RATE IS 2DEG/KM. THIS IS IN ACCORD WITH THE WMO -!! DEFINITION OF A TROPOPAUSE. A MAXIMUM TROPOPAUSE -!! PRESSURE OF 500MB IS ENFORCED. ONC THE TROPOPAUSE -!! IS LOCATED IN A COLUMN, PRESSURE, TEMPERATURE, U -!! AND V WINDS, AND VERTICAL WIND SHEAR ARE COMPUTED. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-22 RUSS TREADON -!! 97-03-06 GEOFF MANIKIN - CHANGED CRITERIA FOR DETERMINING -!! THE TROPOPAUSE AND ADDED HEIGHT -!! 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! 00-01-04 JIM TUCCILLO - MPI VERSION -!! 02-04-23 MIKE BALDWIN - WRF VERSION -!! 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT +!> @brief trpaus() computes tropopause data. +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 -!! -!! USAGE: CALL TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! PTROP - TROPOPAUSE PRESSURE. -!! TTROP - TROPOPAUSE TEMPERATURE. -!! ZTROP - TROPOPAUSE HEIGHT -!! UTROP - TROPOPAUSE U WIND COMPONENT. -!! VTROP - TROPOPAUSE V WIND COMPONENT. -!! SHTROP - VERTICAL WIND SHEAR AT TROPOPAUSE. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! -!! LIBRARY: -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> This routine computes tropopause data. At each mass +!> point a surface up search is made for the first +!> occurrence of a three layer mean lapse rate less than +!> or equal to a critical lapse rate. This critcal lapse +!> rate is 2deg/km. This is in accord with the WMO +!> definition of a tropopause. A maximum tropopause +!> pressure of 500mb is enforced. Onc the tropopause +!> is located in a column, pressure, temperature, u +!> and v winds, and vertical wind shear are computed. +!> +!> @param[out] PTROP Tropopause pressure. +!> @param[out] TTROP Tropopause temperature. +!> @param[out] ZTROP Tropopause height. +!> @param[out] UTROP Tropopause u wind component. +!> @param[out] VTROP Tropopause v wind component. +!> @param[out] SHTROP Vertical wind shear at tropopause. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1997-03-06 | Geoff Manikin | Changed criteria for determining the tropopause and added height +!> 1998-06-15 | T Black | Conversion from 1-D TO 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-23 | Mike Baldwin | WRF Version +!> 2019-10-30 | Bo Cui | ReMOVE "GOTO" STATEMENT +!> 2021-09-13 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! @@ -57,7 +41,8 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) use vrbls3d, only: pint, t, zint, uh, vh use masks, only: lmh use params_mod, only: d50 - use ctlblk_mod, only: jsta, jend, spval, im, jm, lm + use ctlblk_mod, only: jsta, jend, spval, im, jm, lm, & + ista, iend !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -82,7 +67,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! LOOP OVER THE HORIZONTAL GRID. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PTROP(I,J) = SPVAL TTROP(I,J) = SPVAL ZTROP(I,J) = SPVAL @@ -97,7 +82,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) !!$omp& tlapse,tlapse2,u0,u0l,uh,uh0,ul, !!$omp& v0,v0l,vh,vh0) DO J=JSTA,JEND - loopI:DO I=1,IM + loopI:DO I=ISTA,IEND ! ! COMPUTE THE TEMPERATURE LAPSE RATE (-DT/DZ) BETWEEN ETA ! LAYERS MOVING UP FROM THE GROUND. THE FIRST ETA LAYER diff --git a/sorc/ncep_post.fd/TRPAUS_NAM.f b/sorc/ncep_post.fd/TRPAUS_NAM.f index caf8785f4..7ea734f58 100644 --- a/sorc/ncep_post.fd/TRPAUS_NAM.f +++ b/sorc/ncep_post.fd/TRPAUS_NAM.f @@ -1,43 +1,37 @@ !> @file -! -!> SUBPROGRAM: TRPAUS COMPUTE TROPOPAUSE DATA. -!! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES TROPOPAUSE DATA. AT EACH MASS -!! POINT A SURFACE UP SEARCH IS MADE FOR THE FIRST -!! OCCURRENCE OF A THREE LAYER MEAN LAPSE RATE LESS THAN -!! OR EQUAL TO A CRITICAL LAPSE RATE. THIS CRITCAL LAPSE -!! RATE IS 2DEG/KM. THIS IS IN ACCORD WITH THE WMO -!! DEFINITION OF A TROPOPAUSE. A MAXIMUM TROPOPAUSE -!! PRESSURE OF 500MB IS ENFORCED. ONC THE TROPOPAUSE -!! IS LOCATED IN A COLUMN, PRESSURE, TEMPERATURE, U -!! AND V WINDS, AND VERTICAL WIND SHEAR ARE COMPUTED. -!! -!! PROGRAM HISTORY LOG: -!! - 92-12-22 RUSS TREADON -!! - 97-03-06 GEOFF MANIKIN - CHANGED CRITERIA FOR DETERMINING -!! THE TROPOPAUSE AND ADDED HEIGHT -!! - 98-06-15 T BLACK - CONVERSION FROM 1-D TO 2-D -!! - 00-01-04 JIM TUCCILLO - MPI VERSION -!! - 02-04-23 MIKE BALDWIN - WRF VERSION -!! - 19-10-30 Bo CUI - REMOVE "GOTO" STATEMENT -!! -!! USAGE: CALL TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! PTROP - TROPOPAUSE PRESSURE. -!! TTROP - TROPOPAUSE TEMPERATURE. -!! ZTROP - TROPOPAUSE HEIGHT -!! UTROP - TROPOPAUSE U WIND COMPONENT. -!! VTROP - TROPOPAUSE V WIND COMPONENT. -!! SHTROP - VERTICAL WIND SHEAR AT TROPOPAUSE. -!! -!! OUTPUT FILES: -!! NONE -!! +!> @brief trpaus() computes tropopause data. +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 + +!> This routine computes tropopause data. At each mass +!> point a surface up search is made for the first +!> occurrence of a three layer mean lapse rate less than +!> or equal to a critical lapse rate. This critcal lapse +!> rate is 2deg/km. This is in accord with the WMO +!> definition of a tropopause. A maximum tropopause +!> pressure of 500mb is enforced. Onc the tropopause +!> is located in a column, pressure, temperature, u +!> and v winds, and vertical wind shear are computed. +!> +!> @param[out] PTROP Tropopause pressure. +!> @param[out] TTROP Tropopause temperature. +!> @param[out] ZTROP Tropopause height. +!> @param[out] UTROP Tropopause u wind component. +!> @param[out] VTROP Tropopause v wind component. +!> @param[out] SHTROP Vertical wind shear at tropopause. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1997-03-06 | Geoff Manikin | Changed criteria for determining the tropopause and added height +!> 1998-06-15 | T Black | Conversion from 1-D TO 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-04-23 | Mike Baldwin | WRF Version +!> 2019-10-30 | Bo Cui | ReMOVE "GOTO" STATEMENT +!> 2021-09-13 | JESSE MENG | 2D DECOMPOSITION +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! @@ -59,8 +53,8 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! ! DECLARE VARIABLES. ! - REAL PTROP(IM,JM),TTROP(IM,JM),ZTROP(IM,JM),UTROP(IM,JM) - REAL VTROP(IM,JM),SHTROP(IM,JM) + REAL PTROP(ISTA:IEND,JSTA:JEND),TTROP(ISTA:IEND,JSTA:JEND),ZTROP(ISTA:IEND,JSTA:JEND),UTROP(ISTA:IEND,JSTA:JEND) + REAL VTROP(ISTA:IEND,JSTA:JEND),SHTROP(ISTA:IEND,JSTA:JEND) REAL TLAPSE(LM),DZ2(LM),DELT2(LM),TLAPSE2(LM) ! integer I,J @@ -72,7 +66,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) ! LOOP OVER THE HORIZONTAL GRID. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PTROP(I,J) = SPVAL TTROP(I,J) = SPVAL ZTROP(I,J) = SPVAL @@ -87,7 +81,7 @@ SUBROUTINE TRPAUS(PTROP,TTROP,ZTROP,UTROP,VTROP,SHTROP) !$omp& tlapse,tlapse2,u0,u0l,uh,uh0,ul, !$omp& v0,v0l,vh,vh0) DO J=JSTA,JEND - loopI:DO I=1,IM + loopI:DO I=ISTA,IEND ! ! COMPUTE THE TEMPERATURE LAPSE RATE (-DT/DZ) BETWEEN ETA ! LAYERS MOVING UP FROM THE GROUND. THE FIRST ETA LAYER diff --git a/sorc/ncep_post.fd/TTBLEX.f b/sorc/ncep_post.fd/TTBLEX.f index 21748a6f4..5dad0ae76 100644 --- a/sorc/ncep_post.fd/TTBLEX.f +++ b/sorc/ncep_post.fd/TTBLEX.f @@ -19,6 +19,7 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL & ! 00-01-04 JIM TUCCILLO - MPI VERSION ! 01-10-22 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT ! 02-01-15 MIKE BALDWIN - WRF VERSION +! 21-09-13 J MENG - 2D DECOMPOSITION ! ! OUTPUT FILES: ! NONE @@ -30,20 +31,21 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL & ! ATTRIBUTES: ! LANGUAGE: FORTRAN !---------------------------------------------------------------------- - use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, me + use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, me, & + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none !---------------------------------------------------------------------- integer,intent(in) :: ITB,JTB - integer,intent(in) :: KARR(IM,jsta:jend) + integer,intent(in) :: KARR(ista:iend,jsta:jend) real,dimension(JTB,ITB),intent(in) :: TTBL - real,dimension(IM,JSTA_2L:JEND_2U),intent(in) :: PMIDL - real,dimension(IM,JSTA_2L:JEND_2U),intent(out) :: TREF - real,dimension(IM,jsta:jend),intent(out) :: QQ,PP - real,dimension(IM,jsta:jend),intent(in) :: THESP + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in) :: PMIDL + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out) :: TREF + real,dimension(ista:iend,jsta:jend),intent(out) :: QQ,PP + real,dimension(ista:iend,jsta:jend),intent(in) :: THESP real,dimension(ITB), intent(in) :: THE0,STHE - integer,dimension(IM,jsta:jend),intent(out) :: IPTB,ITHTB + integer,dimension(ista:iend,jsta:jend),intent(out) :: IPTB,ITHTB real,intent(in) :: PL,RDP,RDTHE ! @@ -55,7 +57,7 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL & !$omp& private(i,j,bthe00k,bthe10k,bthk,ip,iptbk,ith,pk,sthe00k,sthe10k,& !$omp& sthk,t00k,t01k,t10k,t11k,tpk,tthk) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KARR(I,J) > 0) THEN !--------------SCALING PRESSURE & TT TABLE INDEX------------------------ PK = PMIDL(I,J) diff --git a/sorc/ncep_post.fd/UPP_MATH.f b/sorc/ncep_post.fd/UPP_MATH.f index 2b1ad4a75..a19eaf06d 100644 --- a/sorc/ncep_post.fd/UPP_MATH.f +++ b/sorc/ncep_post.fd/UPP_MATH.f @@ -1,25 +1,25 @@ !> @file -! -!> SUBPROGRAM: UPP_MATH -!! @author JMENG @date 2020-05-20 -!! -!! A collection of UPP subroutines for numerical math functions calculation. -!! -!! DVDXDUDY -!! computes dudy, dvdx, uwnd -!! -!! H2U, H2V, U2H, V2H -!! interpolates variables between U, V, H, points -!! adopted from UPP subroutine GRIDAVG.f -!! -!! PROGRAM HISTORY LOG: -!! MAY 20 2020 Jesse Meng Initial code -!!------------------------------------------------------------------------ -!! +!> +!> @brief upp_math is a collection of UPP subroutines for numerical math functions calculation. +!> @author Jesse Meng @date 2020-05-20 + +!> dvdxdudy() computes dudy, dvdx, uwnd +!> +!> h2u(), h2v(), u2h(), v2h() interpolate variables between U, V, H, points +!> adopted from UPP subroutine GRIDAVG.f +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2020-05-20 | Jesse Meng | Initial +!> 2022-06-10 | Wen Meng | Modify dvdxdudy to retrict computation on undefined grids +!> +!> @author Jesse Meng @date 2020-05-20 module upp_math use masks, only: dx, dy - use ctlblk_mod, only: im, jsta_2l, jend_2u, jsta_m, jend_m, spval + use ctlblk_mod, only: im, jsta_2l, jend_2u, jsta_m, jend_m, spval,& + ista_2l, iend_2u, ista_m, iend_m use gridspec_mod, only: gridtype ! implicit none @@ -43,20 +43,31 @@ subroutine dvdxdudy(uwnd,vwnd) ! implicit none - REAL, dimension(im,jsta_2l:jend_2u), intent(in) :: UWND, VWND + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: UWND, VWND ! !-- local variables !-- integer i, j real r2dx, r2dy INTEGER, allocatable :: IHE(:),IHW(:) -! + +!Initializing + DO J=JSTA_M,JEND_M + DO I=ISTA_M,IEND_M + DDVDX(I,J)=SPVAL + DDUDY(I,J)=SPVAL + UUAVG(I,J)=SPVAL + ENDDO + ENDDO + IF(GRIDTYPE == 'A')THEN !$omp parallel do private(i,j,r2dx,r2dy) DO J=JSTA_M,JEND_M - DO I=2,IM-1 - IF(VWND(I+1,J)1.E-5.AND.ABS(DY(I,J))>1.E-5) THEN R2DX = 1./(2.*DX(I,J)) R2DY = 1./(2.*DY(I,J)) DDVDX(I,J) = (VWND(I+1,J)-VWND(I-1,J))*R2DX @@ -74,7 +85,7 @@ subroutine dvdxdudy(uwnd,vwnd) ENDDO !$omp parallel do private(i,j,r2dx,r2dy) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M IF(VWND(I+IHE(J),J) < SPVAL.AND.VWND(I+IHW(J),J) < SPVAL .AND. & & UWND(I,J+1) < SPVAL .AND.UWND(I,J-1) < SPVAL) THEN R2DX = 1./(2.*DX(I,J)) @@ -90,7 +101,7 @@ subroutine dvdxdudy(uwnd,vwnd) ELSE IF (GRIDTYPE == 'B')THEN !$omp parallel do private(i,j,r2dx,r2dy) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M R2DX = 1./DX(I,J) R2DY = 1./DY(I,J) if(VWND(I, J)==SPVAL .or. VWND(I, J-1)==SPVAL .or. & @@ -115,51 +126,51 @@ subroutine H2U(ingrid,outgrid) ! This subroutine interpolates from H points onto U points ! Author: CHUANG, EMC, Dec. 2010 - use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend, me, num_procs, jm,& - im, jsta_2l, jend_2u , jend_m + use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, me, num_procs, jm,& + im, jsta_2l, jend_2u, ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none INCLUDE "mpif.h" integer:: i,j,ie,iw - real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid - real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid outgrid=spval if(GRIDTYPE == 'A')THEN do j=jsta,jend - do i=1,im + do i=ista,iend outgrid(i,j)=ingrid(i,j) end do end do else IF(GRIDTYPE == 'E')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M IE=I+MOD(J,2) IW=IE-1 outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0 end do end do ELSE IF(GRIDTYPE == 'B')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA,JEND_M - DO I=1,IM-1 + DO I=ISTA,IEND_M outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1)+ingrid(i+1,j)+ingrid(i+1,j+1))/4.0 end do end do ! Fill in boundary points because hysplit fails when 10 m wind has bitmaps do j=jsta,jend_m - outgrid(im,j)=outgrid(im-1,j) + outgrid(iend,j)=outgrid(iend-1,j) end do IF(me == (num_procs-1) .and. jend_2u >= jm) then - DO I=1,IM - outgrid(i,jm) = outgrid(i,jm-1) + DO I=ISTA,IEND + outgrid(i,jend) = outgrid(i,jend-1) END DO END IF ELSE IF(GRIDTYPE == 'C')THEN DO J=JSTA,JEND - DO I=1,IM-1 + DO I=ISTA,IEND_M outgrid(i,j)=(ingrid(i,j)+ingrid(i+1,j))/2.0 end do end do @@ -172,40 +183,41 @@ end subroutine H2U subroutine H2V(ingrid,outgrid) ! This subroutine interpolates from H points onto V points ! Author: CHUANG, EMC, Dec. 2010 - use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u + use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none INCLUDE "mpif.h" integer:: i,j,ie,iw - real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid - real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid outgrid=spval if(GRIDTYPE == 'A')THEN do j=jsta,jend - do i=1,im + do i=ista,iend outgrid(i,j)=ingrid(i,j) end do end do else IF(GRIDTYPE == 'E')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M IE=I+MOD(J,2) IW=IE-1 outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0 end do end do ELSE IF(GRIDTYPE == 'B')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA,JEND_M - DO I=1,IM-1 + DO I=ISTA,IEND_M outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1)+ingrid(i+1,j)+ingrid(i+1,j+1))/4.0 end do end do ELSE IF(GRIDTYPE == 'C')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA,JEND_M - DO I=1,IM + DO I=ISTA,IEND outgrid(i,j)=(ingrid(i,j)+ingrid(i,j+1))/2.0 end do end do @@ -218,39 +230,40 @@ end subroutine H2V subroutine U2H(ingrid,outgrid) ! This subroutine interpolates from U points onto H points ! Author: CHUANG, EMC, Dec. 2010 - use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u + use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none INCLUDE "mpif.h" integer:: i,j,ie,iw - real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid - real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid outgrid=spval if(GRIDTYPE == 'A')THEN do j=jsta,jend - do i=1,im + do i=ista,iend outgrid(i,j)=ingrid(i,j) end do end do else IF(GRIDTYPE == 'E')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M IE=I+MOD(J+1,2) IW=IE-1 outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0 end do end do ELSE IF(GRIDTYPE == 'B')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M outgrid(i,j)=(ingrid(i-1,j-1)+ingrid(i,j-1)+ingrid(i-1,j)+ingrid(i,j))/4.0 end do end do ELSE IF(GRIDTYPE == 'C')THEN DO J=JSTA,JEND - DO I=2,IM + DO I=ISTA_M,IEND outgrid(i,j)=(ingrid(i-1,j)+ingrid(i,j))/2.0 end do end do @@ -263,40 +276,41 @@ end subroutine U2H subroutine V2H(ingrid,outgrid) ! This subroutine interpolates from V points onto H points ! Author: CHUANG, EMC, Dec. 2010 - use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u + use ctlblk_mod, only: spval, jsta, jend, jsta_m, jend_m, im, jsta_2l, jend_2u,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u use gridspec_mod, only: gridtype implicit none INCLUDE "mpif.h" integer:: i,j,ie,iw - real,dimension(IM,JSTA_2L:JEND_2U),intent(in)::ingrid - real,dimension(IM,JSTA_2L:JEND_2U),intent(out)::outgrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(in)::ingrid + real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U),intent(out)::outgrid outgrid=spval if(GRIDTYPE == 'A')THEN do j=jsta,jend - do i=1,im + do i=ista,iend outgrid(i,j)=ingrid(i,j) end do end do else IF(GRIDTYPE == 'E')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M IE=I+MOD(J,2) IW=IE-1 outgrid(i,j)=(ingrid(IW,J)+ingrid(IE,J)+ingrid(I,J+1)+ingrid(I,J-1))/4.0 end do end do ELSE IF(GRIDTYPE == 'B')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND_M - DO I=2,IM-1 + DO I=ISTA_M,IEND_M outgrid(i,j)=(ingrid(i-1,j-1)+ingrid(i,j-1)+ingrid(i-1,j)+ingrid(i,j))/4.0 end do end do ELSE IF(GRIDTYPE == 'C')THEN - call exch(ingrid(1,jsta_2l)) + call exch(ingrid(ista_2l,jsta_2l)) DO J=JSTA_M,JEND - DO I=1,IM + DO I=ISTA,IEND outgrid(i,j)=(ingrid(i,j-1)+ingrid(i,j))/2.0 end do end do diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f index 60a54dee5..cc609aabf 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -1,37 +1,29 @@ !> @file -! -!> SUBPROGRAM: UPP_PHYSICS -!! @author JMENG @date 2020-05-20 -!! -!! A collection of UPP subroutines for physics variables calculation. -!! -!! CALCAPE -!! Compute CAPE/CINS and other storm related variables. -!! -!! CALCAPE2 -!! Compute additional storm related variables. -!! -!! CALRH -!! CALRH_NAM -!! CALRH_GFS -!! CALRH_GSD -!! Compute RH using various algorithms. -!! The NAM v4.1.18 ALGORITHM (CALRH_NAM) is selected as default for -!! NMMB and FV3GFS, FV3GEFS, and FV3R for the UPP 2020 unification. -!! -!! CALRH_PW -!! Algorithm use at GSD for RUC and Rapid Refresh -!! -!! FPVSNEW -!! Compute saturation vapor pressure. -!! -!! TVIRTUAL -!! Compute virtual temperature. -!! -!! PROGRAM HISTORY LOG: -!! MAY, 2020 Jesse Meng Initial code -!!------------------------------------------------------------------------------------- -!! +!> +!> @brief upp_physics is a collection of UPP subroutines for physics variables calculation. +!> @author Jesse Meng @date 2020-05-20 + +!> calcape() computes CAPE/CINS and other storm related variables. +!> +!> calcape2() computes additional storm related variables. +!> +!> calrh(), calrh_nam(), calrh_gfs(), calrh_gsd() compute RH using various algorithms. +!> +!> The NAM v4.1.18 algorithm (calrh_nam()) is selected as default for +!> NMMB and FV3GFS, FV3GEFS, and FV3R for the UPP 2020 unification. +!> +!> calrh_pw() algorithm use at GSD for RUC and Rapid Refresh. +!> +!> fpvsnew() computes saturation vapor pressure. +!> +!> tvirtual() computes virtual temperature. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2020-05-20 | Jesse Meng | Initial +!> +!> @author Jesse Meng @date 2020-05-20 module upp_physics implicit none @@ -39,9 +31,13 @@ module upp_physics private public :: CALCAPE, CALCAPE2 + public :: CALDIV + public :: CALGRADPS public :: CALRH public :: CALRH_GFS, CALRH_GSD, CALRH_NAM public :: CALRH_PW + public :: CALVOR + public :: FPVSNEW public :: TVIRTUAL @@ -51,12 +47,12 @@ module upp_physics ! SUBROUTINE CALRH(P1,T1,Q1,RH) - use ctlblk_mod, only: im, jsta, jend, MODELNAME + use ctlblk_mod, only: ista, iend, jsta, jend, MODELNAME implicit none - REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1 - REAL,dimension(IM,jsta:jend),intent(inout) :: Q1 - REAL,dimension(IM,jsta:jend),intent(out) :: RH + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: Q1 + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH IF(MODELNAME == 'RAPR')THEN CALL CALRH_GSD(P1,T1,Q1,RH) @@ -68,57 +64,37 @@ END SUBROUTINE CALRH ! !------------------------------------------------------------------------------------- ! - SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) -! SUBROUTINE CALRH(P1,T1,Q1,RH) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALRH COMPUTES RELATIVE HUMIDITY -! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES RELATIVE HUMIDITY GIVEN PRESSURE, -! TEMPERATURE, SPECIFIC HUMIDITY. AN UPPER AND LOWER BOUND -! OF 100 AND 1 PERCENT RELATIVE HUMIDITY IS ENFORCED. WHEN -! THESE BOUNDS ARE APPLIED THE PASSED SPECIFIC HUMIDITY -! ARRAY IS ADJUSTED AS NECESSARY TO PRODUCE THE SET RELATIVE -! HUMIDITY. -! . -! -! PROGRAM HISTORY LOG: -! ??-??-?? DENNIS DEAVEN -! 92-12-22 RUSS TREADON - MODIFIED AS DESCRIBED ABOVE. -! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 MIKE BALDWIN - MODIFY TO COMPUTE RH OVER ICE AS IN MODEL -! 98-12-16 GEOFF MANIKIN - UNDO RH COMPUTATION OVER ICE -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-06-11 MIKE BALDWIN - WRF VERSION -! 06-03-19 Wen Meng - MODIFY TOP PRESSURE to 1 PA -! -! USAGE: CALL CALRH(P1,T1,Q1,RH) -! INPUT ARGUMENT LIST: -! P1 - PRESSURE (PA) -! T1 - TEMPERATURE (K) -! Q1 - SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT ARGUMENT LIST: -! RH - RELATIVE HUMIDITY (DECIMAL FORM) -! Q1 - ADJUSTED SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! LIBRARY: -! NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : CRAY C-90 -!$$$ -! +!> calrh_nam() computes relative humidity. +!> +!> This routine computes relative humidity given pressure, +!> temperature, specific humidity. an upper and lower bound +!> of 100 and 1 percent relative humidity is enforced. When +!> these bounds are applied the passed specific humidity +!> array is adjusted as necessary to produce the set relative +!> humidity. +!> +!> @param[in] P1 Pressure (pa) +!> @param[in] T1 Temperature (K) +!> @param[in] Q1 Specific humidity (kg/kg) +!> @param[out] RH Relative humidity (decimal form) +!> @param[out] Q1 Specific humidity (kg/kg) +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> ????-??-?? | DENNIS DEAVEN | Initial +!> 1992-12-22 | Russ Treadon | Modified as described above +!> 1998-06-08 | T Black | Conversion from 1-D to 2-D +!> 1998-08-18 | Mike Baldwin | Modify to compute RH over ice as in model +!> 1998-12-16 | Geoff Manikin | undo RH computation over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-11 | Mike Baldwin | WRF Version +!> 2006-03-19 | Wen Meng | Modify top pressure to 1 pa +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 + SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) use params_mod, only: PQ0, a2, a3, a4, rhmin - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -126,9 +102,9 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) ! ! DECLARE VARIABLES. ! - REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1 - REAL,dimension(IM,jsta:jend),intent(inout) :: Q1 - REAL,dimension(IM,jsta:jend),intent(out) :: RH + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1 + REAL,dimension(ista:iend,jsta:jend),intent(inout) :: Q1 + REAL,dimension(ista:iend,jsta:jend),intent(out) :: RH REAL QC integer I,J !*************************************************************** @@ -136,7 +112,7 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH) ! START CALRH. ! DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T1(I,J) < spval) THEN IF (ABS(P1(I,J)) >= 1) THEN QC = PQ0/P1(I,J)*EXP(A2*(T1(I,J)-A3)/(T1(I,J)-A4)) @@ -167,57 +143,38 @@ END SUBROUTINE CALRH_NAM ! !------------------------------------------------------------------------------------- ! +!> calrh_gfs() computes relative humidity. +!> +!> This routine computes relative humidity given pressure, +!> temperature, specific humidity. an upper and lower bound +!> of 100 and 1 percent relative humidity is enforced. When +!> these bounds are applied the passed specific humidity +!> array is adjusted as necessary to produce the set relative +!> humidity. +!> +!> @param[in] P1 Pressure (pa) +!> @param[in] T1 Temperature (K) +!> @param[in] Q1 Specific humidity (kg/kg) +!> @param[out] RH Relative humidity (decimal form) +!> @param[out] Q1 Specific humidity (kg/kg) +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> ????-??-?? | DENNIS DEAVEN | Initial +!> 1992-12-22 | Russ Treadon | Modified as described above +!> 1998-06-08 | T Black | Conversion from 1-D to 2-D +!> 1998-08-18 | Mike Baldwin | Modify to compute RH over ice as in model +!> 1998-12-16 | Geoff Manikin | undo RH computation over ice +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-06-11 | Mike Baldwin | WRF Version +!> 2013-08-13 | S. Moorthi | Threading +!> 2006-03-19 | Wen Meng | Modify top pressure to 1 pa +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALRH COMPUTES RELATIVE HUMIDITY -! PRGRMMR: TREADON ORG: W/NP2 DATE: 92-12-22 -! -! ABSTRACT: -! THIS ROUTINE COMPUTES RELATIVE HUMIDITY GIVEN PRESSURE, -! TEMPERATURE, SPECIFIC HUMIDITY. AN UPPER AND LOWER BOUND -! OF 100 AND 1 PERCENT RELATIVE HUMIDITY IS ENFORCED. WHEN -! THESE BOUNDS ARE APPLIED THE PASSED SPECIFIC HUMIDITY -! ARRAY IS ADJUSTED AS NECESSARY TO PRODUCE THE SET RELATIVE -! HUMIDITY. -! . -! -! PROGRAM HISTORY LOG: -! ??-??-?? DENNIS DEAVEN -! 92-12-22 RUSS TREADON - MODIFIED AS DESCRIBED ABOVE. -! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 MIKE BALDWIN - MODIFY TO COMPUTE RH OVER ICE AS IN MODEL -! 98-12-16 GEOFF MANIKIN - UNDO RH COMPUTATION OVER ICE -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-06-11 MIKE BALDWIN - WRF VERSION -! 13-08-13 S. Moorthi - Threading -! 06-03-19 Wen Meng - MODIFY TOP PRESSURE to 1 PA -! -! USAGE: CALL CALRH(P1,T1,Q1,RH) -! INPUT ARGUMENT LIST: -! P1 - PRESSURE (PA) -! T1 - TEMPERATURE (K) -! Q1 - SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT ARGUMENT LIST: -! RH - RELATIVE HUMIDITY (DECIMAL FORM) -! Q1 - ADJUSTED SPECIFIC HUMIDITY (KG/KG) -! -! OUTPUT FILES: -! NONE -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! LIBRARY: -! NONE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! MACHINE : CRAY C-90 -!$$$ -! use params_mod, only: rhmin - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -234,8 +191,8 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) ! END FUNCTION FPVSNEW ! END INTERFACE ! - REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1 - REAL,dimension(IM,jsta:jend),intent(inout):: Q1,RH + REAL,dimension(ista:iend,jsta:jend),intent(in) :: P1,T1 + REAL,dimension(ista:iend,jsta:jend),intent(inout):: Q1,RH REAL ES,QC integer :: I,J !*************************************************************** @@ -244,7 +201,7 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) ! !$omp parallel do private(i,j,es,qc) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T1(I,J) < spval .AND. P1(I,J) < spval.AND.Q1(I,J)/=spval) THEN ! IF (ABS(P1(I,J)) > 1.0) THEN ! IF (P1(I,J) > 1.0) THEN @@ -284,17 +241,17 @@ SUBROUTINE CALRH_GSD(P1,T1,Q1,RHB) !------------------------------------------------------------------ ! - use ctlblk_mod, only: jsta, jend, im, spval + use ctlblk_mod, only: ista, iend, jsta, jend, spval implicit none integer :: j, i real :: tx, pol, esx, es, e - real, dimension(im,jsta:jend) :: P1, T1, Q1, RHB + real, dimension(ista:iend,jsta:jend) :: P1, T1, Q1, RHB DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (T1(I,J) < spval .AND. P1(I,J) < spval .AND. Q1(I,J) < spval) THEN ! - compute relative humidity Tx=T1(I,J)-273.15 @@ -326,13 +283,13 @@ SUBROUTINE CALRH_PW(RHPW) use vrbls3d, only: q, pmid, t use params_mod, only: g - use ctlblk_mod, only: lm, jsta, jend, lm, im, spval + use ctlblk_mod, only: lm, ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none real,PARAMETER :: svp1=6.1153,svp2=17.67,svp3=29.65 - REAL, dimension(im,jsta:jend):: PW, PW_SAT, RHPW + REAL, dimension(ista:iend,jsta:jend):: PW, PW_SAT, RHPW REAL deltp,sh,qv,temp,es,qs,qv_sat integer i,j,l,k,ka,kb @@ -343,7 +300,7 @@ SUBROUTINE CALRH_PW(RHPW) DO L=1,LM k=lm-l+1 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ! -- use specific humidity for PW calculation if(t(i,j,k) fpvsnew() computes saturation vapor pressure. +!> +!> Compute saturation vapor pressure from the temperature. +!> A linear interpolation is done between values in a lookup table +!> computed in gpvs. See documentation for fpvsx for details. +!> Input values outside table range are reset to table extrema. +!> The interpolation accuracy is almost 6 decimal places. +!> On the Cray, fpvs is about 4 times faster than exact calculation. +!> This function should be expanded inline in the calling routine. +!> +!> @param[in] t Real(krealfp) Temperature in Kelvin. +!> @param[out] fpvsnew Real(krealfp) Saturation vapor pressure in Pascals. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1991-05-07 | Iredell | Initial. Made into inlinable function +!> 1994-12-30 | Iredell | Expand table +!> 1999-03-01 | Iredell | F90 module +!> 2001-02-26 | Iredell | Ice phase +!> +!> @author N Phillips w/NMC2X2 @date 1982-12-30 implicit none integer,parameter:: nxpvs=7501 real,parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt @@ -486,130 +434,98 @@ elemental function fpvsnew(t) end function fpvsnew ! !------------------------------------------------------------------------------------- -! - +!> calcape() computes CAPE and CINS. +!> +!> This routine computes CAPE and CINS given temperature, +!> pressure, and specific humidty. In "storm and cloud +!> dynamics" (1989, academic press) cotton and anthes define +!> CAPE (equation 9.16, p501) as +!> +!> @code +!> EL +!> CAPE = SUM G * LN(THETAP/THETAA) DZ +!> LCL +!> +!> Where, +!> EL = Equilibrium level, +!> LCL = Lifting condenstation level, +!> G = Gravitational acceleration, +!> THETAP = Lifted parcel potential temperature, +!> THETAA = Ambient potential temperature. +!> @endcode +!> +!> Note that the integrand ln(THETAP/THETAA) approximately +!> equals (THETAP-THETAA)/THETAA. This ratio is often used +!> in the definition of CAPE/CINS. +!> +!> Two types of CAPE/CINS can be computed by this routine. The +!> summation process is the same For both cases. What differs +!> is the definition of the parcel to lift. FOR ITYPE=1 the +!> parcel with the warmest THETA-E in A DPBND pascal layer above +!> the model surface is lifted. the arrays P1D, T1D, and Q1D +!> are not used. For itype=2 the arrays P1D, T1D, and Q1D +!> define the parcel to lift in each column. Both types of +!> CAPE/CINS may be computed in a single execution of the post +!> processor. +!> +!> This algorithm proceeds as follows. +!> For each column, +!> (1) Initialize running CAPE and CINS SUM TO 0.0 +!> (2) Compute temperature and pressure at the LCL using +!> look up table (PTBL). Use either parcel that gives +!> max THETAE in lowest DPBND above ground (ITYPE=1) +!> or given parcel from t1D,Q1D,...(ITYPE=2). +!> (3) Compute the temp of a parcel lifted from the LCL. +!> We know that the parcel's +!> equivalent potential temperature (THESP) remains +!> constant through this process. we can +!> compute tpar using this knowledge using look +!> up table (subroutine TTBLEX). +!> (4) Find the equilibrium level. This is defined as the +!> highest positively buoyant layer. +!> (If there is no positively buoyant layer, CAPE/CINS +!> will be zero) +!> (5) Compute CAPE/CINS. +!> (A) Compute THETAP. We know TPAR and P. +!> (B) Compute THETAA. We know T and P. +!> (6) Add G*(THETAP-THETAA)*DZ to the running CAPE or CINS sum. +!> (A) If THETAP > THETAA, add to the CAPE sum. +!> (B) If THETAP < THETAA, add to the CINS sum. +!> (7) Are we at equilibrium level? +!> (A) If yes, stop the summation. +!> (b) if no, contiunue the summation. +!> (8) Enforce limits on CAPE and CINS (i.e. no negative CAPE) +!> +!> @param[in] ITYPE INTEGER Flag specifying how parcel to lift is identified. See comments above. +!> @param[in] DPBND Depth over which one searches for most unstable parcel. +!> @param[in] P1D Array of pressure of parcels to lift. +!> @param[in] T1D Array of temperature of parcels to lift. +!> @param[in] Q1D Array of specific humidity of parcels to lift. +!> @param[in] L1D Array of model level of parcels to lift. +!> @param[out] CAPE Convective available potential energy (J/kg). +!> @param[out] CINS Convective inhibition (J/kg). +!> @param[out] PPARC Pressure level of parcel lifted when one searches over a particular depth to compute CAPE/CIN. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-02-10 | Russ Treadon | Initial +!> 1993-06-19 | Russ Treadon | Generalized routine to allow for type 2 CAPE/CINS calculations +!> 1994-09-23 | Mike Baldwin | Modified to use look up tables instead of complicated equations +!> 1994-10-13 | Mike Baldwin | Modified to continue CAPE/CINS calc up to at highest buoyant layer +!> 1998-06-12 | T Black | Conversion from 1-D TO 2-D +!> 1998-08-18 | T Black | Compute APE internally +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-01-15 | Mike Baldwin | WRF Version +!> 2003-08-24 | G Manikin | Added level of parcel being lifted as output from the routine and added the depth over which one searches for the most unstable parcel as input +!> 2010-09-09 | G Manikin | Changed computation to use virtual temp added eq lvl hght and thunder parameter +!> 2015-??-?? | S Moorthi | Optimization and threading +!> 2021-07-28 | W Meng | Restrict computation from undefined grids +!> 2021-09-01 | E Colon | Equivalent level height index for RTMA +!> +!> @author Russ Treadon W/NP2 @date 1993-02-10 SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & CINS,PPARC,ZEQL,THUND) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALCAPE COMPUTES CAPE AND CINS -! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-10 -! -! ABSTRACT: -! -! THIS ROUTINE COMPUTES CAPE AND CINS GIVEN TEMPERATURE, -! PRESSURE, AND SPECIFIC HUMIDTY. IN "STORM AND CLOUD -! DYNAMICS" (1989, ACADEMIC PRESS) COTTON AND ANTHES DEFINE -! CAPE (EQUATION 9.16, P501) AS -! -! EL -! CAPE = SUM G * LN(THETAP/THETAA) DZ -! LCL -! -! WHERE, -! EL = EQUILIBRIUM LEVEL, -! LCL = LIFTING CONDENSTATION LEVEL, -! G = GRAVITATIONAL ACCELERATION, -! THETAP = LIFTED PARCEL POTENTIAL TEMPERATURE, -! THETAA = AMBIENT POTENTIAL TEMPERATURE. -! -! NOTE THAT THE INTEGRAND LN(THETAP/THETAA) APPROXIMATELY -! EQUALS (THETAP-THETAA)/THETAA. THIS RATIO IS OFTEN USED -! IN THE DEFINITION OF CAPE/CINS. -! -! TWO TYPES OF CAPE/CINS CAN BE COMPUTED BY THIS ROUTINE. THE -! SUMMATION PROCESS IS THE SAME FOR BOTH CASES. WHAT DIFFERS -! IS THE DEFINITION OF THE PARCEL TO LIFT. FOR ITYPE=1 THE -! PARCEL WITH THE WARMEST THETA-E IN A DPBND PASCAL LAYER ABOVE -! THE MODEL SURFACE IS LIFTED. THE ARRAYS P1D, T1D, AND Q1D -! ARE NOT USED. FOR ITYPE=2 THE ARRAYS P1D, T1D, AND Q1D -! DEFINE THE PARCEL TO LIFT IN EACH COLUMN. BOTH TYPES OF -! CAPE/CINS MAY BE COMPUTED IN A SINGLE EXECUTION OF THE POST -! PROCESSOR. -! -! THIS ALGORITHM PROCEEDS AS FOLLOWS. -! FOR EACH COLUMN, -! (1) INITIALIZE RUNNING CAPE AND CINS SUM TO 0.0 -! (2) COMPUTE TEMPERATURE AND PRESSURE AT THE LCL USING -! LOOK UP TABLE (PTBL). USE EITHER PARCEL THAT GIVES -! MAX THETAE IN LOWEST DPBND ABOVE GROUND (ITYPE=1) -! OR GIVEN PARCEL FROM T1D,Q1D,...(ITYPE=2). -! (3) COMPUTE THE TEMP OF A PARCEL LIFTED FROM THE LCL. -! WE KNOW THAT THE PARCEL'S -! EQUIVALENT POTENTIAL TEMPERATURE (THESP) REMAINS -! CONSTANT THROUGH THIS PROCESS. WE CAN -! COMPUTE TPAR USING THIS KNOWLEDGE USING LOOK -! UP TABLE (SUBROUTINE TTBLEX). -! (4) FIND THE EQUILIBRIUM LEVEL. THIS IS DEFINED AS THE -! HIGHEST POSITIVELY BUOYANT LAYER. -! (IF THERE IS NO POSITIVELY BUOYANT LAYER, CAPE/CINS -! WILL BE ZERO) -! (5) COMPUTE CAPE/CINS. -! (A) COMPUTE THETAP. WE KNOW TPAR AND P. -! (B) COMPUTE THETAA. WE KNOW T AND P. -! (6) ADD G*(THETAP-THETAA)*DZ TO THE RUNNING CAPE OR CINS SUM. -! (A) IF THETAP > THETAA, ADD TO THE CAPE SUM. -! (B) IF THETAP < THETAA, ADD TO THE CINS SUM. -! (7) ARE WE AT EQUILIBRIUM LEVEL? -! (A) IF YES, STOP THE SUMMATION. -! (B) IF NO, CONTIUNUE THE SUMMATION. -! (8) ENFORCE LIMITS ON CAPE AND CINS (I.E. NO NEGATIVE CAPE) -! -! PROGRAM HISTORY LOG: -! 93-02-10 RUSS TREADON -! 93-06-19 RUSS TREADON - GENERALIZED ROUTINE TO ALLOW FOR -! TYPE 2 CAPE/CINS CALCULATIONS. -! 94-09-23 MIKE BALDWIN - MODIFIED TO USE LOOK UP TABLES -! INSTEAD OF COMPLICATED EQUATIONS. -! 94-10-13 MIKE BALDWIN - MODIFIED TO CONTINUE CAPE/CINS CALC -! UP TO AT HIGHEST BUOYANT LAYER. -! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 T BLACK - COMPUTE APE INTERNALLY -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 03-08-24 G MANIKIN - ADDED LEVEL OF PARCEL BEING LIFTED -! AS OUTPUT FROM THE ROUTINE AND ADDED -! THE DEPTH OVER WHICH ONE SEARCHES FOR -! THE MOST UNSTABLE PARCEL AS INPUT -! 10-09-09 G MANIKIN - CHANGED COMPUTATION TO USE VIRTUAL TEMP -! - ADDED EQ LVL HGHT AND THUNDER PARAMETER -! 15-xx-xx S MOORTHI - optimization and threading -! 21-07-28 W Meng - Restrict computation from undefined grids. -! 21-09-01 E COLON - equivalent level height index for RTMA -! -! USAGE: CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, -! CINS,PPARC) -! INPUT ARGUMENT LIST: -! ITYPE - INTEGER FLAG SPECIFYING HOW PARCEL TO LIFT IS -! IDENTIFIED. SEE COMMENTS ABOVE. -! DPBND - DEPTH OVER WHICH ONE SEARCHES FOR MOST UNSTABLE PARCEL -! P1D - ARRAY OF PRESSURE OF PARCELS TO LIFT. -! T1D - ARRAY OF TEMPERATURE OF PARCELS TO LIFT. -! Q1D - ARRAY OF SPECIFIC HUMIDITY OF PARCELS TO LIFT. -! L1D - ARRAY OF MODEL LEVEL OF PARCELS TO LIFT. -! -! OUTPUT ARGUMENT LIST: -! CAPE - CONVECTIVE AVAILABLE POTENTIAL ENERGY (J/KG) -! CINS - CONVECTIVE INHIBITION (J/KG) -! PPARC - PRESSURE LEVEL OF PARCEL LIFTED WHEN ONE SEARCHES -! OVER A PARTICULAR DEPTH TO COMPUTE CAPE/CIN -! -! OUTPUT FILES: -! STDOUT - RUN TIME STANDARD OUT. -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! BOUND - BOUND (CLIP) DATA BETWEEN UPPER AND LOWER LIMTS. -! TTBLEX - LOOKUP TABLE ROUTINE TO GET T FROM THETAE AND P -! -! LIBRARY: -! COMMON - -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : CRAY C-90 -!$$$ -! use vrbls3d, only: pmid, t, q, zint use vrbls2d, only: teql,ieql use masks, only: lmh @@ -618,7 +534,8 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, & plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, & itbq, jtbq, rdpq, the0q, stheq, rdtheq - use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, me, spval + use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, me, spval, & + ista_2l, iend_2u, ista, iend ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -630,16 +547,16 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! integer,intent(in) :: ITYPE real,intent(in) :: DPBND - integer, dimension(IM,Jsta:jend),intent(in) :: L1D - real, dimension(IM,Jsta:jend),intent(in) :: P1D,T1D - real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL + integer, dimension(ista:iend,Jsta:jend),intent(in) :: L1D + real, dimension(ista:iend,Jsta:jend),intent(in) :: P1D,T1D + real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL ! - integer, dimension(im,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX + integer, dimension(ista:iend,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX ! - real, dimension(im,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND + real, dimension(ista:iend,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND REAL, ALLOCATABLE :: TPAR(:,:,:) - LOGICAL THUNDER(IM,jsta:jend), NEEDTHUN + LOGICAL THUNDER(ista:iend,jsta:jend), NEEDTHUN real PSFCK,PKL,TBTK,QBTK,APEBTK,TTHBTK,TTHK,APESPK,TPSPK, & BQS00K,SQS00K,BQS10K,SQS10K,BQK,SQK,TQK,PRESK,GDZKL,THETAP, & THETAA,P00K,P10K,P01K,P11K,TTHESK,ESATP,QSATP,TVP,TV @@ -651,7 +568,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !************************************************************** ! START CALCAPE HERE. ! - ALLOCATE(TPAR(IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE(TPAR(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) ! ! COMPUTE CAPE/CINS ! @@ -675,7 +592,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CAPE(I,J) = D00 CAPE20(I,J) = D00 CINS(I,J) = D00 @@ -692,7 +609,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !$omp parallel do DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TPAR(I,J,L) = D00 ENDDO ENDDO @@ -705,7 +622,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & IF (ITYPE == 2) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Q1D(I,J) = MIN(MAX(H1M12,Q1D(I,J)),H99999) ENDDO ENDDO @@ -722,7 +639,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, & !$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PSFCK = PMID(I,J,NINT(LMH(I,J))) PKL = PMID(I,J,KB) IF(PSFCK NINT(LMH(I,J))) LCL(I,J) = NINT(LMH(I,J)) IF (ITYPE > 2) THEN IF (T(I,J,LCL(I,J)) < 263.15) THEN @@ -850,7 +767,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & KNUML = 0 KNUMH = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND KLRES(I,J) = 0 KHRES(I,J) = 0 IF(L <= LCL(I,J)) THEN @@ -868,23 +785,23 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES & - , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES & + , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & , RDTHE,THESP,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ !** IF(KNUMH > 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & - , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & + , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ & ,THE0Q,STHEQ,RDTHEQ,THESP,IPTB,ITHTB) ENDIF !------------SEARCH FOR EQ LEVEL---------------------------------------- !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KHRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L ENDIF @@ -893,7 +810,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KLRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L) .AND. & PMID(I,J,L)>100.) IEQL(I,J) = L @@ -906,7 +823,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & LBEG = 1000 LEND = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LBEG = MIN(IEQL(I,J),LBEG) LEND = MAX(LCL(I,J),LEND) ENDDO @@ -914,7 +831,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,IEQL(I,J)) > 255.65) THEN THUNDER(I,J) = .FALSE. ENDIF @@ -925,7 +842,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IDX(I,J) = 0 IF(L >= IEQL(I,J).AND.L <= LCL(I,J)) THEN IDX(I,J) = 1 @@ -935,7 +852,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(IDX(I,J) > 0) THEN PRESK = PMID(I,J,L) GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G @@ -966,7 +883,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CAPE(I,J) = MAX(D00,CAPE(I,J)) CINS(I,J) = MIN(CINS(I,J),D00) ! add equillibrium height @@ -988,140 +905,104 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & END SUBROUTINE CALCAPE ! !------------------------------------------------------------------------------------- -! +!> calcape2() computes CAPE and CINS. +!> +!> This routine computes CAPE and CINS given temperature, +!> pressure, and specific humidty. In "storm and cloud +!> dynamics" (1989, academic press) cotton and anthes define +!> CAPE (equation 9.16, p501) as +!> +!> @code +!> EL +!> CAPE = SUM G * ln(THETAP/THETAA) DZ +!> LCL +!> +!> Where, +!> EL = Equilibrium level, +!> LCL = Lifting condenstation level, +!> G = Gravitational acceleration, +!> THETAP = Lifted parcel potential temperature, +!> THETAA = Ambient potential temperature. +!> @endcode +!> +!> Note that the integrand ln(THETAP/THETAA) approximately +!> equals (THETAP-THETAA)/THETAA. This ratio is often used +!> in the definition of CAPE/CINS. +!> +!> Two types of CAPE/CINS can be computed by this routine. The +!> summation process is the same For both cases. What differs +!> is the definition of the parcel to lift. FOR ITYPE=1 the +!> parcel with the warmest THETA-E in A DPBND pascal layer above +!> the model surface is lifted. the arrays P1D, T1D, and Q1D +!> are not used. For itype=2 the arrays P1D, T1D, and Q1D +!> define the parcel to lift in each column. Both types of +!> CAPE/CINS may be computed in a single execution of the post +!> processor. +!> +!> This algorithm proceeds as follows. +!> For each column, +!> (1) Initialize running CAPE and CINS SUM TO 0.0 +!> (2) Compute temperature and pressure at the LCL using +!> look up table (PTBL). Use either parcel that gives +!> max THETAE in lowest DPBND above ground (ITYPE=1) +!> or given parcel from t1D,Q1D,...(ITYPE=2). +!> (3) Compute the temp of a parcel lifted from the LCL. +!> We know that the parcel's +!> equivalent potential temperature (THESP) remains +!> constant through this process. we can +!> compute tpar using this knowledge using look +!> up table (subroutine TTBLEX). +!> (4) Find the equilibrium level. This is defined as the +!> highest positively buoyant layer. +!> (If there is no positively buoyant layer, CAPE/CINS +!> will be zero) +!> (5) Compute CAPE/CINS. +!> (A) Compute THETAP. We know TPAR and P. +!> (B) Compute THETAA. We know T and P. +!> (6) Add G*(THETAP-THETAA)*DZ to the running CAPE or CINS sum. +!> (A) If THETAP > THETAA, add to the CAPE sum. +!> (B) If THETAP < THETAA, add to the CINS sum. +!> (7) Are we at equilibrium level? +!> (A) If yes, stop the summation. +!> (b) if no, contiunue the summation. +!> (8) Enforce limits on CAPE and CINS (i.e. no negative CAPE) +!> +!> @param[in] ITYPE INTEGER Flag specifying how parcel to lift is identified. See comments above. +!> @param[in] DPBND Depth over which one searches for most unstable parcel. +!> @param[in] P1D Array of pressure of parcels to lift. +!> @param[in] T1D Array of temperature of parcels to lift. +!> @param[in] Q1D Array of specific humidity of parcels to lift. +!> @param[in] L1D Array of model level of parcels to lift. +!> @param[out] CAPE Convective available potential energy (J/kg). +!> @param[out] CINS Convective inhibition (J/kg). +!> @param[out] LFC level of free convection (m). +!> @param[out] ESRHL Lower bound to account for effective helicity calculation. +!> @param[out] ESRHH Upper bound to account for effective helicity calculation. +!> @param[out] DCAPE downdraft CAPE (J/KG). +!> @param[out] DGLD Dendritic growth layer depth (m). +!> @param[out] ESP Enhanced stretching potential. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1993-02-10 | Russ Treadon | Initial +!> 1993-06-19 | Russ Treadon | Generalized routine to allow for type 2 CAPE/CINS calculations +!> 1994-09-23 | Mike Baldwin | Modified to use look up tables instead of complicated equations +!> 1994-10-13 | Mike Baldwin | Modified to continue CAPE/CINS calc up to at highest buoyant layer +!> 1998-06-12 | T Black | Conversion from 1-D TO 2-D +!> 1998-08-18 | T Black | Compute APE internally +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-01-15 | Mike Baldwin | WRF Version +!> 2003-08-24 | G Manikin | Added level of parcel being lifted as output from the routine and added the depth over which one searches for the most unstable parcel as input +!> 2010-09-09 | G Manikin | Changed computation to use virtual temp added eq lvl hght and thunder parameter +!> 2015-??-?? | S Moorthi | Optimization and threading +!> 2021-09-03 | J Meng | Modified to add 0-3km CAPE/CINS, LFC, effective helicity, downdraft CAPE, dendritic growth layer depth, ESP +!> 2021-09-01 | E Colon | Equivalent level height index for RTMA +!> +!> @author Russ Treadon W/NP2 @date 1993-02-10 SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & CAPE,CINS,LFC,ESRHL,ESRHH, & DCAPE,DGLD,ESP) -! SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, & -! CINS,PPARC,ZEQL,THUND) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALCAPE COMPUTES CAPE AND CINS -! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-10 -! -! ABSTRACT: -! -! THIS ROUTINE COMPUTES CAPE AND CINS GIVEN TEMPERATURE, -! PRESSURE, AND SPECIFIC HUMIDTY. IN "STORM AND CLOUD -! DYNAMICS" (1989, ACADEMIC PRESS) COTTON AND ANTHES DEFINE -! CAPE (EQUATION 9.16, P501) AS -! -! EL -! CAPE = SUM G * LN(THETAP/THETAA) DZ -! LCL -! -! WHERE, -! EL = EQUILIBRIUM LEVEL, -! LCL = LIFTING CONDENSTATION LEVEL, -! G = GRAVITATIONAL ACCELERATION, -! THETAP = LIFTED PARCEL POTENTIAL TEMPERATURE, -! THETAA = AMBIENT POTENTIAL TEMPERATURE. -! -! NOTE THAT THE INTEGRAND LN(THETAP/THETAA) APPROXIMATELY -! EQUALS (THETAP-THETAA)/THETAA. THIS RATIO IS OFTEN USED -! IN THE DEFINITION OF CAPE/CINS. -! -! TWO TYPES OF CAPE/CINS CAN BE COMPUTED BY THIS ROUTINE. THE -! SUMMATION PROCESS IS THE SAME FOR BOTH CASES. WHAT DIFFERS -! IS THE DEFINITION OF THE PARCEL TO LIFT. FOR ITYPE=1 THE -! PARCEL WITH THE WARMEST THETA-E IN A DPBND PASCAL LAYER ABOVE -! THE MODEL SURFACE IS LIFTED. THE ARRAYS P1D, T1D, AND Q1D -! ARE NOT USED. FOR ITYPE=2 THE ARRAYS P1D, T1D, AND Q1D -! DEFINE THE PARCEL TO LIFT IN EACH COLUMN. BOTH TYPES OF -! CAPE/CINS MAY BE COMPUTED IN A SINGLE EXECUTION OF THE POST -! PROCESSOR. -! -! THIS ALGORITHM PROCEEDS AS FOLLOWS. -! FOR EACH COLUMN, -! (1) INITIALIZE RUNNING CAPE AND CINS SUM TO 0.0 -! (2) COMPUTE TEMPERATURE AND PRESSURE AT THE LCL USING -! LOOK UP TABLE (PTBL). USE EITHER PARCEL THAT GIVES -! MAX THETAE IN LOWEST DPBND ABOVE GROUND (ITYPE=1) -! OR GIVEN PARCEL FROM T1D,Q1D,...(ITYPE=2). -! (3) COMPUTE THE TEMP OF A PARCEL LIFTED FROM THE LCL. -! WE KNOW THAT THE PARCEL'S -! EQUIVALENT POTENTIAL TEMPERATURE (THESP) REMAINS -! CONSTANT THROUGH THIS PROCESS. WE CAN -! COMPUTE TPAR USING THIS KNOWLEDGE USING LOOK -! UP TABLE (SUBROUTINE TTBLEX). -! (4) FIND THE EQUILIBRIUM LEVEL. THIS IS DEFINED AS THE -! HIGHEST POSITIVELY BUOYANT LAYER. -! (IF THERE IS NO POSITIVELY BUOYANT LAYER, CAPE/CINS -! WILL BE ZERO) -! (5) COMPUTE CAPE/CINS. -! (A) COMPUTE THETAP. WE KNOW TPAR AND P. -! (B) COMPUTE THETAA. WE KNOW T AND P. -! (6) ADD G*(THETAP-THETAA)*DZ TO THE RUNNING CAPE OR CINS SUM. -! (A) IF THETAP > THETAA, ADD TO THE CAPE SUM. -! (B) IF THETAP < THETAA, ADD TO THE CINS SUM. -! (7) ARE WE AT EQUILIBRIUM LEVEL? -! (A) IF YES, STOP THE SUMMATION. -! (B) IF NO, CONTIUNUE THE SUMMATION. -! (8) ENFORCE LIMITS ON CAPE AND CINS (I.E. NO NEGATIVE CAPE) -! -! PROGRAM HISTORY LOG: -! 93-02-10 RUSS TREADON -! 93-06-19 RUSS TREADON - GENERALIZED ROUTINE TO ALLOW FOR -! TYPE 2 CAPE/CINS CALCULATIONS. -! 94-09-23 MIKE BALDWIN - MODIFIED TO USE LOOK UP TABLES -! INSTEAD OF COMPLICATED EQUATIONS. -! 94-10-13 MIKE BALDWIN - MODIFIED TO CONTINUE CAPE/CINS CALC -! UP TO AT HIGHEST BUOYANT LAYER. -! 98-06-12 T BLACK - CONVERSION FROM 1-D TO 2-D -! 98-08-18 T BLACK - COMPUTE APE INTERNALLY -! 00-01-04 JIM TUCCILLO - MPI VERSION -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 03-08-24 G MANIKIN - ADDED LEVEL OF PARCEL BEING LIFTED -! AS OUTPUT FROM THE ROUTINE AND ADDED -! THE DEPTH OVER WHICH ONE SEARCHES FOR -! THE MOST UNSTABLE PARCEL AS INPUT -! 10-09-09 G MANIKIN - CHANGED COMPUTATION TO USE VIRTUAL TEMP -! - ADDED EQ LVL HGHT AND THUNDER PARAMETER -! 15-xx-xx S MOORTHI - optimization and threading -! 19-09-03 J MENG - MODIFIED TO ADD 0-3KM CAPE/CINS, LFC, -! EFFECTIVE HELICITY, DOWNDRAFT CAPE, -! DENDRITIC GROWTH LAYER DEPTH, ESP -! 21-09-01 E COLON - equivalent level height index for RTMA -! -! USAGE: CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & -! CAPE,CINS,LFC,ESRHL,ESRHH, & -! DCAPE,DGLD,ESP) -! -! INPUT ARGUMENT LIST: -! ITYPE - INTEGER FLAG SPECIFYING HOW PARCEL TO LIFT IS -! IDENTIFIED. SEE COMMENTS ABOVE. -! DPBND - DEPTH OVER WHICH ONE SEARCHES FOR MOST UNSTABLE PARCEL -! P1D - ARRAY OF PRESSURE OF PARCELS TO LIFT. -! T1D - ARRAY OF TEMPERATURE OF PARCELS TO LIFT. -! Q1D - ARRAY OF SPECIFIC HUMIDITY OF PARCELS TO LIFT. -! L1D - ARRAY OF MODEL LEVEL OF PARCELS TO LIFT. -! -! OUTPUT ARGUMENT LIST: -! CAPE - CONVECTIVE AVAILABLE POTENTIAL ENERGY (J/KG) -! CINS - CONVECTIVE INHIBITION (J/KG) -! LFC - LEVEL OF FREE CONVECTION (M) -! ESRHL - LOWER BOUND TO ACCOUNT FOR EFFECTIVE HELICITY CALCULATION -! ESRHH - UPPER BOUND TO ACCOUNT FOR EFFECTIVE HELICITY CALCULATION -! DCAPE - DOWNDRAFT CAPE (J/KG) -! DGLD - DENDRITIC GROWTH LAYER DEPTH (M) -! ESP - ENHANCED STRETCHING POTENTIAL -! -! OUTPUT FILES: -! STDOUT - RUN TIME STANDARD OUT. -! -! SUBPROGRAMS CALLED: -! UTILITIES: -! BOUND - BOUND (CLIP) DATA BETWEEN UPPER AND LOWER LIMTS. -! TTBLEX - LOOKUP TABLE ROUTINE TO GET T FROM THETAE AND P -! -! LIBRARY: -! COMMON - -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : CRAY C-90 -!$$$ -! use vrbls3d, only: pmid, t, q, zint use vrbls2d, only: fis,ieql use gridspec_mod, only: gridtype @@ -1131,7 +1012,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, & plq, ttbl, pl, rdp, the0, sthe, rdthe, ttblq, & itbq, jtbq, rdpq, the0q, stheq, rdtheq - use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval + use ctlblk_mod, only: jsta_2l, jend_2u, lm, jsta, jend, im, jm, me, jsta_m, jend_m, spval,& + ista_2l, iend_2u, ista, iend, ista_m, iend_m ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -1143,25 +1025,25 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! integer,intent(in) :: ITYPE real,intent(in) :: DPBND - integer, dimension(IM,Jsta:jend),intent(in) :: L1D - real, dimension(IM,Jsta:jend),intent(in) :: P1D,T1D -! real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL - real, dimension(IM,jsta:jend),intent(inout) :: Q1D,CAPE,CINS - real, dimension(IM,jsta:jend) :: PPARC,ZEQL - real, dimension(IM,jsta:jend),intent(inout) :: LFC,ESRHL,ESRHH - real, dimension(IM,jsta:jend),intent(inout) :: DCAPE,DGLD,ESP - integer, dimension(im,jsta:jend) ::L12,L17,L3KM + integer, dimension(ista:iend,Jsta:jend),intent(in) :: L1D + real, dimension(ista:iend,Jsta:jend),intent(in) :: P1D,T1D +! real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS,PPARC,ZEQL + real, dimension(ista:iend,jsta:jend),intent(inout) :: Q1D,CAPE,CINS + real, dimension(ista:iend,jsta:jend) :: PPARC,ZEQL + real, dimension(ista:iend,jsta:jend),intent(inout) :: LFC,ESRHL,ESRHH + real, dimension(ista:iend,jsta:jend),intent(inout) :: DCAPE,DGLD,ESP + integer, dimension(ista:iend,jsta:jend) ::L12,L17,L3KM ! - integer, dimension(im,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX + integer, dimension(ista:iend,jsta:jend) :: IPTB, ITHTB, PARCEL, KLRES, KHRES, LCL, IDX ! - real, dimension(im,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND - integer, dimension(im,jsta:jend) :: PARCEL2 - real, dimension(im,jsta:jend) :: THESP2,PSP2 - real, dimension(im,jsta:jend) :: CAPE4,CINS4 + real, dimension(ista:iend,jsta:jend) :: THESP, PSP, CAPE20, QQ, PP, THUND + integer, dimension(ista:iend,jsta:jend) :: PARCEL2 + real, dimension(ista:iend,jsta:jend) :: THESP2,PSP2 + real, dimension(ista:iend,jsta:jend) :: CAPE4,CINS4 REAL, ALLOCATABLE :: TPAR(:,:,:) REAL, ALLOCATABLE :: TPAR2(:,:,:) - LOGICAL THUNDER(IM,jsta:jend), NEEDTHUN + LOGICAL THUNDER(ista:iend,jsta:jend), NEEDTHUN real PSFCK,PKL,TBTK,QBTK,APEBTK,TTHBTK,TTHK,APESPK,TPSPK, & BQS00K,SQS00K,BQS10K,SQS10K,BQK,SQK,TQK,PRESK,GDZKL,THETAP, & THETAA,P00K,P10K,P01K,P11K,TTHESK,ESATP,QSATP,TVP,TV @@ -1170,15 +1052,15 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ, KB,ITTBK integer IE,IW,JN,JS,IVE(JM),IVW(JM),JVN,JVS integer ISTART,ISTOP,JSTART,JSTOP - real, dimension(IM,jsta:jend) :: HTSFC + real, dimension(ista:iend,jsta:jend) :: HTSFC ! integer I,J,L,KNUML,KNUMH,LBEG,LEND,IQ,IT,LMHK, KB,ITTBK ! !************************************************************** ! START CALCAPE HERE. ! - ALLOCATE(TPAR(IM,JSTA_2L:JEND_2U,LM)) - ALLOCATE(TPAR2(IM,JSTA_2L:JEND_2U,LM)) + ALLOCATE(TPAR(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) + ALLOCATE(TPAR2(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM)) ! ! COMPUTE CAPE/CINS ! @@ -1202,7 +1084,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CAPE(I,J) = D00 CAPE20(I,J) = D00 CAPE4(I,J) = D00 @@ -1230,7 +1112,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do DO L=1,LM DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND TPAR(I,J,L) = D00 TPAR2(I,J,L) = D00 ENDDO @@ -1246,8 +1128,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IVE(J) = MOD(J,2) IVW(J) = IVE(J)-1 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE IF(gridtype == 'B')THEN @@ -1257,8 +1139,8 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IVE(J)=1 IVW(J)=0 enddo - ISTART = 2 - ISTOP = IM-1 + ISTART = ISTA_M + ISTOP = IEND_M JSTART = JSTA_M JSTOP = JEND_M ELSE @@ -1268,13 +1150,13 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IVE(J) = 0 IVW(J) = 0 enddo - ISTART = 1 - ISTOP = IM + ISTART = ISTA + ISTOP = IEND JSTART = JSTA JSTOP = JEND END IF !!$omp parallel do private(htsfc,ie,iw) - IF(gridtype /= 'A') CALL EXCH(FIS(1:IM,JSTA:JEND)) + IF(gridtype /= 'A') CALL EXCH(FIS(ISTA:IEND,JSTA:JEND)) DO J=JSTART,JSTOP DO I=ISTART,ISTOP IE = I+IVE(J) @@ -1299,7 +1181,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & IF (ITYPE == 2) THEN !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND Q1D(I,J) = MIN(MAX(H1M12,Q1D(I,J)),H99999) ENDDO ENDDO @@ -1316,7 +1198,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp & p00k,p01k,p10k,p11k,pkl,psfck,qbtk,sqk,sqs00k, & !$omp & sqs10k,tbtk,tpspk,tqk,tthbtk,tthesk,tthk) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PSFCK = PMID(I,J,NINT(LMH(I,J))) PKL = PMID(I,J,KB) @@ -1412,7 +1294,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !----FIND THE PRESSURE OF THE PARCEL THAT WAS LIFTED !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND PPARC(I,J) = PMID(I,J,PARCEL(I,J)) ENDDO ENDDO @@ -1423,14 +1305,14 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=1,LM !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (PMID(I,J,L) < PSP(I,J)) LCL(I,J) = L+1 ENDDO ENDDO ENDDO !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF (LCL(I,J) > NINT(LMH(I,J))) LCL(I,J) = NINT(LMH(I,J)) IF (ITYPE > 2) THEN IF (T(I,J,LCL(I,J)) < 263.15) THEN @@ -1447,7 +1329,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & KNUML = 0 KNUMH = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND KLRES(I,J) = 0 KHRES(I,J) = 0 IF(L <= LCL(I,J)) THEN @@ -1465,23 +1347,23 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES & - , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES & + , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & , RDTHE,THESP,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ !** IF(KNUMH > 0) THEN - CALL TTBLEX(TPAR(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & - , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ & + CALL TTBLEX(TPAR(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & + , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ & ,THE0Q,STHEQ,RDTHEQ,THESP,IPTB,ITHTB) ENDIF !------------SEARCH FOR EQ LEVEL---------------------------------------- !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KHRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L ENDIF @@ -1490,7 +1372,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(KLRES(I,J) > 0) THEN IF(TPAR(I,J,L) > T(I,J,L)) IEQL(I,J) = L ENDIF @@ -1502,7 +1384,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & LBEG = 1000 LEND = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND LBEG = MIN(IEQL(I,J),LBEG) LEND = MAX(LCL(I,J),LEND) ENDDO @@ -1510,7 +1392,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,IEQL(I,J)) > 255.65) THEN THUNDER(I,J) = .FALSE. ENDIF @@ -1526,7 +1408,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IDX(I,J) = 0 IF(L >= IEQL(I,J).AND.L <= LCL(I,J)) THEN IDX(I,J) = 1 @@ -1537,7 +1419,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv,& !$omp & presk2,esatp2,qsatp2,tvp2,thetap2,tv2,thetaa2) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(IDX(I,J) > 0) THEN PRESK = PMID(I,J,L) GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G @@ -1598,7 +1480,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ESRHH(I,J) > ESRHL(I,J)) ESRHH(I,J)=IEQL(I,J) ENDDO ENDDO @@ -1609,7 +1491,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND CAPE(I,J) = MAX(D00,CAPE(I,J)) CINS(I,J) = MIN(CINS(I,J),D00) ! equillibrium height @@ -1637,7 +1519,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & KNUML = 0 KNUMH = 0 DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND KLRES(I,J) = 0 KHRES(I,J) = 0 PSFCK = PMID(I,J,NINT(LMH(I,J))) @@ -1657,16 +1539,16 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE 0) THEN - CALL TTBLEX(TPAR2(1,JSTA_2L,L),TTBL,ITB,JTB,KLRES & - , PMID(1,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TPAR2(ISTA_2L,JSTA_2L,L),TTBL,ITB,JTB,KLRES & + , PMID(ISTA_2L,JSTA_2L,L),PL,QQ,PP,RDP,THE0,STHE & , RDTHE,THESP2,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PLQ !** IF(KNUMH > 0) THEN - CALL TTBLEX(TPAR2(1,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & - , PMID(1,JSTA_2L,L),PLQ,QQ,PP,RDPQ & + CALL TTBLEX(TPAR2(ISTA_2L,JSTA_2L,L),TTBLQ,ITBQ,JTBQ,KHRES & + , PMID(ISTA_2L,JSTA_2L,L),PLQ,QQ,PP,RDPQ & , THE0Q,STHEQ,RDTHEQ,THESP2,IPTB,ITHTB) ENDIF ENDDO ! end of do l=lm,1,-1 loop @@ -1677,7 +1559,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=LBEG,LEND !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IDX(I,J) = 0 IF(L >= PARCEL2(I,J).AND.L < NINT(LMH(I,J))) THEN IDX(I,J) = 1 @@ -1687,7 +1569,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ! !$omp parallel do private(i,j,gdzkl,presk,thetaa,thetap,esatp,qsatp,tvp,tv) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(IDX(I,J) > 0) THEN PRESK = PMID(I,J,L) GDZKL = (ZINT(I,J,L)-ZINT(I,J,L+1)) * G @@ -1709,7 +1591,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND DCAPE(I,J) = MIN(D00,DCAPE(I,J)) ENDDO ENDDO @@ -1725,7 +1607,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=LM,1,-1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(T(I,J,L) <= TFRZ-12. .AND. L12(I,J)==LM) L12(I,J)=L IF(T(I,J,L) <= TFRZ-17. .AND. L17(I,J)==LM) L17(I,J)=L ENDDO @@ -1733,7 +1615,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & ENDDO !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(L12(I,J)/=LM .AND. L17(I,J)/=LM) THEN DGLD(I,J)=ZINT(I,J,L17(I,J))-ZINT(I,J,L12(I,J)) DGLD(I,J)=MAX(DGLD(I,J),0.) @@ -1749,14 +1631,14 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, & DO L=LM,1,-1 !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ZINT(I,J,L)-HTSFC(I,J) <= 3000.) L3KM(I,J)=L ENDDO ENDDO ENDDO !$omp parallel do private(i,j) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND ESP(I,J) = (CAPE(I,J) / 50.) * (T(I,J,LM) - T(I,J,L3KM(I,J)) - 7.0) IF((T(I,J,LM) - T(I,J,L3KM(I,J))) < 7.0) ESP(I,J) = 0. ! IF(CAPE(I,J) < 250.) ESP(I,J) = 0. @@ -1786,5 +1668,969 @@ elemental function TVIRTUAL(T,Q) end function TVIRTUAL ! !------------------------------------------------------------------------------------- +! +!> @file +!> @brief Subroutine that computes absolute vorticity. +!> +!> This routine computes the absolute vorticity. +!> +!> @param[in] UWND U wind (m/s) mass-points. +!> @param[in] VWND V wind (m/s) mass-points. +!> @param[out] ABSV absolute vorticity (1/s) mass-points. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-22 | Russ Treadon | Initial +!> 1998-06-08 | T Black | Convesion from 1-D to 2-D +!> 2000-01-04 | Jim Tuccillo | MPI Version +!> 2002-01-15 | Mike Baldwin | WRF Version C-grid +!> 2005-03-01 | H Chuang | Add NMM E grid +!> 2005-05-17 | H Chuang | Add Potential vorticity calculation +!> 2005-07-07 | B Zhou | Add RSM in computing DVDX, DUDY and UAVG +!> 2013-08-09 | S Moorthi | Optimize the vorticity loop including threading +!> 2016-08-05 | S Moorthi | add zonal filetering +!> 2019-10-17 | Y Mao | Skip calculation when U/V is SPVAL +!> 2020-11-06 | J Meng | Use UPP_MATH Module +!> 2022-05-26 | H Chuang | Use GSL approach for FV3R +!> +!> @author Russ Treadon W/NP2 @date 1992-12-22 + SUBROUTINE CALVOR(UWND,VWND,ABSV) + +! +! + use vrbls2d, only: f + use masks, only: gdlat, gdlon, dx, dy + use params_mod, only: d00, dtr, small, erad + use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & + jsta, jend, im, jm, jsta_m, jend_m, gdsdegr,& + ista, iend, ista_m, iend_m, ista_2l, iend_2u, me, num_procs + use gridspec_mod, only: gridtype, dyval + use upp_math, only: DVDXDUDY, DDVDX, DDUDY, UUAVG + + implicit none +! +! DECLARE VARIABLES. +! + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: UWND, VWND + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) :: ABSV + REAL, dimension(IM,2) :: GLATPOLES, COSLPOLES, UPOLES, AVPOLES + REAL, dimension(IM,JSTA:JEND) :: COSLTEMP, AVTEMP +! + real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:) + INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:) +! + integer, parameter :: npass2=2, npass3=3 + integer I,J,ip1,im1,ii,iir,iil,jj,JMT2,imb2, npass, nn, jtem + real R2DX,R2DY,DVDX,DUDY,UAVG,TPH1,TPHI, tx1(im+2), tx2(im+2) +! +!*************************************************************************** +! START CALVOR HERE. +! +! LOOP TO COMPUTE ABSOLUTE VORTICITY FROM WINDS. +! + IF(MODELNAME == 'RAPR') then +!$omp parallel do private(i,j) + DO J=JSTA_2L,JEND_2U + DO I=ISTA_2L,IEND_2U + ABSV(I,J) = D00 + ENDDO + ENDDO + else +!$omp parallel do private(i,j) + DO J=JSTA_2L,JEND_2U + DO I=ISTA_2L,IEND_2U + ABSV(I,J) = SPVAL + ENDDO + ENDDO + endif + +! print*,'dyval in CALVOR= ',DYVAL + + CALL EXCH(UWND) + CALL EXCH(VWND) +! + IF (MODELNAME == 'GFS' .or. global) THEN + CALL EXCH(GDLAT(ISTA_2L,JSTA_2L)) + CALL EXCH(GDLON(ISTA_2L,JSTA_2L)) + + allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), & + & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(iw(im),ie(im)) + + imb2 = im/2 +!$omp parallel do private(i) + do i=ista,iend + ie(i) = i+1 + iw(i) = i-1 + enddo +! iw(1) = im +! ie(im) = 1 + +! if(1>=jsta .and. 1<=jend)then +! if(cos(gdlat(1,1)*dtr)= SMALL) then + wrk1(i,j) = 1.0 / (ERAD*cosl(i,j)) + else + wrk1(i,j) = 0. + end if + if(i == im .or. i == 1) then + wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam + else + wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam + end if + enddo + enddo +! CALL EXCH(cosl(1,JSTA_2L)) + CALL EXCH(cosl) + + call fullpole( cosl(ista_2l:iend_2u,jsta_2l:jend_2u),coslpoles) + call fullpole(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles) + + if(me==0 ) print*,'CALVOR ',me,glatpoles(ista,1),glatpoles(ista,2) + if(me==num_procs-1) print*,'CALVOR ',me,glatpoles(ista,1),glatpoles(ista,2) + +!$omp parallel do private(i,j,ii) + DO J=JSTA,JEND + if (j == 1) then + if(gdlat(ista,j) > 0.) then ! count from north to south + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GLATPOLES(ii,1))*DTR) !1/dphi + enddo + else ! count from south to north + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GLATPOLES(ii,1))*DTR) !1/dphi +! + enddo + end if + elseif (j == JM) then + if(gdlat(ista,j) < 0.) then ! count from north to south + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GLATPOLES(ii,2))*DTR) + enddo + else ! count from south to north + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR) + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GLATPOLES(ii,2))*DTR) + enddo + end if + else + do i=ista,iend + wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi + enddo + endif + enddo + + npass = 0 + + jtem = jm / 18 + 1 + + call fullpole(uwnd(ista_2l:iend_2u,jsta_2l:jend_2u),upoles) + +!$omp parallel do private(i,j,ip1,im1,ii,jj,tx1,tx2) + DO J=JSTA,JEND +! npass = npass2 +! if (j > jm-jtem+1 .or. j < jtem) npass = npass3 + IF(J == 1) then ! Near North or South pole + if(gdlat(ista,j) > 0.) then ! count from north to south + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & +! UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle + UPOLES(II,1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & +! & + (UWND(II,J)*COSL(II,J) & + & + (upoles(II,1)*coslpoles(II,1) & + & + UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) & + & + F(I,J) + enddo + ELSE !pole point, compute at j=2 + jj = 2 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & + UWND(I,J)==SPVAL .or. UWND(I,jj+1)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & + & - (UWND(I,J)*COSL(I,J) & + - UWND(I,jj+1)*COSL(I,Jj+1))*wrk3(i,jj)) * wrk1(i,jj) & + & + F(I,Jj) + enddo + ENDIF + else + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & +! UWND(II,J)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle + UPOLES(II,1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & +! & - (UWND(II,J)*COSL(II,J) & + & - (upoles(II,1)*coslpoles(II,1) & + & + UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) & + & + F(I,J) + enddo + ELSE !pole point, compute at j=2 + jj = 2 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & + UWND(I,J)==SPVAL .or. UWND(I,jj+1)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & + & + (UWND(I,J)*COSL(I,J) & + - UWND(I,jj+1)*COSL(I,Jj+1))*wrk3(i,jj)) * wrk1(i,jj) & + & + F(I,Jj) + enddo + ENDIF + endif + ELSE IF(J == JM) THEN ! Near North or South Pole + if(gdlat(ista,j) < 0.) then ! count from north to south + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & +! UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle + UWND(I,J-1)==SPVAL .or. UPOLES(II,2)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & + & - (UWND(I,J-1)*COSL(I,J-1) & +! & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) & + & + upoles(II,2)*coslpoles(II,2))*wrk3(i,j)) * wrk1(i,j) & + & + F(I,J) + enddo + ELSE !pole point,compute at jm-1 + jj = jm-1 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & + UWND(I,jj-1)==SPVAL .or. UWND(I,J)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & + & - (UWND(I,jj-1)*COSL(I,Jj-1) & + & - UWND(I,J)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) & + & + F(I,Jj) + enddo + ENDIF + else + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & +! UWND(I,J-1)==SPVAL .or. UWND(II,J)==SPVAL) cycle + UWND(I,J-1)==SPVAL .or. UPOLES(II,2)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & + & + (UWND(I,J-1)*COSL(I,J-1) & +! & + UWND(II,J)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) & + & + upoles(II,2)*coslpoles(II,2))*wrk3(i,j)) * wrk1(i,j) & + & + F(I,J) + enddo + ELSE !pole point,compute at jm-1 + jj = jm-1 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + if(VWND(ip1,JJ)==SPVAL .or. VWND(im1,JJ)==SPVAL .or. & + UWND(I,jj-1)==SPVAL .or. UWND(I,J)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,JJ)-VWND(im1,JJ))*wrk2(i,jj) & + & + (UWND(I,jj-1)*COSL(I,Jj-1) & + & - UWND(I,J)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) & + & + F(I,Jj) + enddo + ENDIF + endif + ELSE + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + if(VWND(ip1,J)==SPVAL .or. VWND(im1,J)==SPVAL .or. & + UWND(I,J-1)==SPVAL .or. UWND(I,J+1)==SPVAL) cycle + ABSV(I,J) = ((VWND(ip1,J)-VWND(im1,J))*wrk2(i,j) & + & - (UWND(I,J-1)*COSL(I,J-1) & + - UWND(I,J+1)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) & + + F(I,J) + ENDDO + END IF +! if(ABSV(I,J)>1.0)print*,'Debug CALVOR',i,j,VWND(ip1,J),VWND(im1,J), & +! wrk2(i,j),UWND(I,J-1),COSL(I,J-1),UWND(I,J+1),COSL(I,J+1),wrk3(i,j),cosl(i,j),F(I,J),ABSV(I,J) + if (npass > 0) then + do i=ista,iend + tx1(i) = absv(i,j) + enddo + do nn=1,npass + do i=ista,iend + tx2(i+1) = tx1(i) + enddo + tx2(1) = tx2(im+1) + tx2(im+2) = tx2(2) + do i=2,im+1 + tx1(i-1) = 0.25 * (tx2(i-1) + tx2(i+1)) + 0.5*tx2(i) + enddo + enddo + do i=ista,iend + absv(i,j) = tx1(i) + enddo + endif + END DO ! end of J loop + +! deallocate (wrk1, wrk2, wrk3, cosl) +! GFS use lon avg as one scaler value for pole point + + ! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,ABSV(1,jsta)) + + call exch(absv(ista_2l:iend_2u,jsta_2l:jend_2u)) + call fullpole(absv(ista_2l:iend_2u,jsta_2l:jend_2u),avpoles) + + cosltemp=spval + if(jsta== 1) cosltemp(1:im, 1)=coslpoles(1:im,1) + if(jend==jm) cosltemp(1:im,jm)=coslpoles(1:im,2) + avtemp=spval + if(jsta== 1) avtemp(1:im, 1)=avpoles(1:im,1) + if(jend==jm) avtemp(1:im,jm)=avpoles(1:im,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,cosltemp(1,jsta),SPVAL,avtemp(1,jsta)) + + if(jsta== 1) absv(ista:iend, 1)=avtemp(ista:iend, 1) + if(jend==jm) absv(ista:iend,jm)=avtemp(ista:iend,jm) + + deallocate (wrk1, wrk2, wrk3, cosl, iw, ie) + + ELSE !(MODELNAME == 'GFS' .or. global) + + IF (GRIDTYPE == 'B')THEN + CALL EXCH(VWND) + CALL EXCH(UWND) + ENDIF + + CALL DVDXDUDY(UWND,VWND) + + IF(GRIDTYPE == 'A')THEN +!$omp parallel do private(i,j,jmt2,tphi,r2dx,r2dy,dvdx,dudy,uavg) + DO J=JSTA_M,JEND_M + JMT2 = JM/2+1 + TPHI = (J-JMT2)*(DYVAL/gdsdegr)*DTR + DO I=ISTA_M,IEND_M + IF(DDVDX(I,J) CALDIV computes divergence. +!> +!> For GFS, this routine copmutes the horizontal divergence +!> using 2nd-order centered scheme on a lat-lon grid +!> +!> @param[in] UWND U wind (m/s) mass-points. +!> @param[in] VWND V wind (m/s) mass-points. +!> @param[out] DIV divergence (1/s) mass-points. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2016-05-05 | Sajal Kar | Modified CALVORT to compute divergence from wind components +!> 2016-07-22 | S Moorthi | Modified polar divergence calculation +!> +!> @author Sajal Kar W/NP2 @date 2016-05-05 + SUBROUTINE CALDIV(UWND,VWND,DIV) + use masks, only: gdlat, gdlon + use params_mod, only: d00, dtr, small, erad + use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & + jsta, jend, im, jm, jsta_m, jend_m, lm, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u + use gridspec_mod, only: gridtype + + implicit none +! +! DECLARE VARIABLES. +! + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm), intent(in) :: UWND,VWND + REAL, dimension(ista:iend,jsta:jend,lm), intent(inout) :: DIV + REAL, dimension(IM,2) :: GLATPOLES, COSLPOLES, UPOLES, VPOLES, DIVPOLES + REAL, dimension(IM,JSTA:JEND) :: COSLTEMP, DIVTEMP +! + real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:) + INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:) +! + real :: dnpole, dspole, tem + integer I,J,ip1,im1,ii,iir,iil,jj,imb2, l +! +!*************************************************************************** +! START CALDIV HERE. +! +! LOOP TO COMPUTE DIVERGENCE FROM WINDS. +! + CALL EXCH(GDLAT(ISTA_2L,JSTA_2L)) + CALL EXCH(GDLON(ISTA_2L,JSTA_2L)) + + allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), & + & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(iw(im),ie(im)) + + imb2 = im/2 +!$omp parallel do private(i) + do i=ista,iend + ie(i) = i+1 + iw(i) = i-1 + enddo +! iw(1) = im +! ie(im) = 1 + + +!$omp parallel do private(i,j,ip1,im1) + DO J=JSTA,JEND + do i=ista,iend + ip1 = ie(i) + im1 = iw(i) + cosl(i,j) = cos(gdlat(i,j)*dtr) + IF(cosl(i,j) >= SMALL) then + wrk1(i,j) = 1.0 / (ERAD*cosl(i,j)) + else + wrk1(i,j) = 0. + end if + if(i == im .or. i == 1) then + wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam + else + wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam + end if + enddo + ENDDO + + CALL EXCH(cosl) + CALL FULLPOLE(cosl,coslpoles) + CALL FULLPOLE(gdlat(ista_2l:iend_2u,jsta_2l:jend_2u),glatpoles) + +!$omp parallel do private(i,j,ii) + DO J=JSTA,JEND + if (j == 1) then + if(gdlat(ista,j) > 0.) then ! count from north to south + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GLATPOLES(II,1))*DTR) !1/dphi + enddo + else ! count from south to north + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GLATPOLES(II,1))*DTR) !1/dphi + enddo + end if + elseif (j == JM) then + if(gdlat(ista,j) < 0.) then ! count from north to south + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GLATPOLES(II,2))*DTR) + enddo + else ! count from south to north + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + ! wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR) + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GLATPOLES(II,2))*DTR) + enddo + end if + else + do i=ista,iend + wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi + enddo + endif + enddo + + do l=1,lm +!$omp parallel do private(i,j) + DO J=JSTA,JEND + DO I=ISTA,IEND + DIV(I,J,l) = SPVAL + ENDDO + ENDDO + + CALL EXCH(VWND(ista_2l,jsta_2l,l)) + CALL EXCH(UWND(ista_2l,jsta_2l,l)) + + CALL FULLPOLE(VWND(ista_2l:iend_2u,jsta_2l:jend_2u,l),VPOLES) + CALL FULLPOLE(UWND(ista_2l:iend_2u,jsta_2l:jend_2u,l),UPOLES) + +!$omp parallel do private(i,j,ip1,im1,ii,jj) + DO J=JSTA,JEND + IF(J == 1) then ! Near North pole + if(gdlat(ista,j) > 0.) then ! count from north to south + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & + !& ! - (VWND(II,J,l)*COSL(II,J) & + & - (VPOLES(II,1)*COSLPOLEs(II,1) & + & + VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) + enddo +!-- + ELSE !North pole point, compute at j=2 + jj = 2 + do i=ista,iend + ip1 = ie(i) + im1 = iw(i) + DIV(I,J,l) = ((UWND(ip1,jj,l)-UWND(im1,jj,l))*wrk2(i,jj) & + & + (VWND(I,J,l)*COSL(I,J) & + - VWND(I,jj+1,l)*COSL(I,jj+1))*wrk3(i,jj)) * wrk1(i,jj) + enddo +!-- + ENDIF + else + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & + !& ! + (VWND(II,J,l)*COSL(II,J) & + & + (VPOLES(II,1)*COSLPOLES(II,1) & + & + VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) + enddo +!-- + ELSE !North pole point, compute at j=2 + jj = 2 + do i=ista,iend + ip1 = ie(i) + im1 = iw(i) + DIV(I,J,l) = ((UWND(ip1,jj,l)-UWND(im1,jj,l))*wrk2(i,jj) & + & - (VWND(I,J,l)*COSL(I,J) & + - VWND(I,jj+1,l)*COSL(I,jj+1))*wrk3(i,jj)) * wrk1(i,jj) + enddo + ENDIF + endif + ELSE IF(J == JM) THEN ! Near South pole + if(gdlat(ista,j) < 0.) then ! count from north to south + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & + & + (VWND(I,J-1,l)*COSL(I,J-1) & + !& ! + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) + & + VPOLES(II,2)*COSLPOLES(II,2))*wrk3(i,j)) * wrk1(i,j) + enddo +!-- + ELSE !South pole point,compute at jm-1 + jj = jm-1 + do i=ista,iend + ip1 = ie(i) + im1 = iw(i) + DIV(I,J,l) = ((UWND(ip1,JJ,l)-UWND(im1,JJ,l))*wrk2(i,jj) & + & + (VWND(I,jj-1,l)*COSL(I,Jj-1) & + & - VWND(I,J,l)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) + + enddo + ENDIF + else + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & + & - (VWND(I,J-1,l)*COSL(I,J-1) & + !& ! + VWND(II,J,l)*COSL(II,J))*wrk3(i,j)) * wrk1(i,j) + & + VPOLES(II,2)*COSLPOLES(II,2))*wrk3(i,j)) * wrk1(i,j) + enddo +!-- + ELSE !South pole point,compute at jm-1 + jj = jm-1 + do i=ista,iend + ip1 = ie(i) + im1 = iw(i) + DIV(I,J,l) = ((UWND(ip1,JJ,l)-UWND(im1,JJ,l))*wrk2(i,jj) & + & - (VWND(I,jj-1,l)*COSL(I,Jj-1) & + & - VWND(I,J,l)*COSL(I,J))*wrk3(i,jj)) * wrk1(i,jj) + + enddo + ENDIF + endif + ELSE + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + DIV(I,J,l) = ((UWND(ip1,J,l)-UWND(im1,J,l))*wrk2(i,j) & + & + (VWND(I,J-1,l)*COSL(I,J-1) & + - VWND(I,J+1,l)*COSL(I,J+1))*wrk3(i,j)) * wrk1(i,j) +!sk06132016 + if(DIV(I,J,l)>1.0)print*,'Debug in CALDIV',i,j,UWND(ip1,J,l),UWND(im1,J,l), & + & wrk2(i,j),VWND(I,J-1,l),COSL(I,J-1),VWND(I,J+1,l),COSL(I,J+1), & + & wrk3(i,j),wrk1(i,j),DIV(I,J,l) +!-- + ENDDO + ENDIF + ENDDO ! end of J loop + +! GFS use lon avg as one scaler value for pole point +! call poleavg(IM,JM,JSTA,JEND,SMALL,COSL(1,jsta),SPVAL,DIV(1,jsta,l)) + + call exch(div(ista_2l:iend_2u,jsta_2l:jend_2u,l)) + call fullpole(div(ista_2l:iend_2u,jsta_2l:jend_2u,l),divpoles) + + COSLTEMP=SPVAL + IF(JSTA== 1) COSLTEMP(1:IM, 1)=COSLPOLES(1:IM,1) + IF(JEND==JM) COSLTEMP(1:IM,JM)=COSLPOLES(1:IM,2) + DIVTEMP=SPVAL + IF(JSTA== 1) DIVTEMP(1:IM, 1)=DIVPOLES(1:IM,1) + IF(JEND==JM) DIVTEMP(1:IM,JM)=DIVPOLES(1:IM,2) + + call poleavg(IM,JM,JSTA,JEND,SMALL,COSLTEMP(1:IM,JSTA:JEND) & + ,SPVAL,DIVTEMP(1:IM,JSTA:JEND)) + + IF(JSTA== 1) DIV(ISTA:IEND, 1,L)=DIVTEMP(ISTA:IEND, 1) + IF(JEND==JM) DIV(ISTA:IEND,JM,L)=DIVTEMP(ISTA:IEND,JM) + +!sk06142016e + if(DIV(ista,jsta,l)>1.0)print*,'Debug in CALDIV',jsta,DIV(ista,jsta,l) +! print*,'Debug in CALDIV',' jsta= ',jsta,DIV(1,jsta,l) + + enddo ! end of l looop +!-- + deallocate (wrk1, wrk2, wrk3, cosl, iw, ie) + + + END SUBROUTINE CALDIV + + SUBROUTINE CALGRADPS(PS,PSX,PSY) +!> CALGRADPS computes gardients of a scalar field PS or LNPS. +!> +!> For GFS, this routine computes horizontal gradients of PS or LNPS. +!> Using 2nd-order centered scheme on a lat-lon grid. +!> +!> @param[in] PS Surface pressure (Pa) mass-points. +!> @param[out] PSX Zonal gradient of PS at mass-points. +!> @param[out] PSY Meridional gradient of PS at mass-points. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2016-05-05 | Sajal Kar | Reduced from CALVORT to zonal and meridional gradients of given surface pressure PS, or LNPS +!> +!> @author Sajal Kar W/NP2 @date 2016-05-05 + use masks, only: gdlat, gdlon + use params_mod, only: dtr, d00, small, erad + use ctlblk_mod, only: jsta_2l, jend_2u, spval, modelname, global, & + jsta, jend, im, jm, jsta_m, jend_m, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u + + use gridspec_mod, only: gridtype + + implicit none +! +! DECLARE VARIABLES. +! + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(in) :: PS + REAL, dimension(ista_2l:iend_2u,jsta_2l:jend_2u), intent(inout) :: PSX,PSY +! + real, allocatable :: wrk1(:,:), wrk2(:,:), wrk3(:,:), cosl(:,:) + INTEGER, allocatable :: IHE(:),IHW(:), IE(:),IW(:) +! + integer I,J,ip1,im1,ii,iir,iil,jj,imb2 +! +!*************************************************************************** +! START CALGRADPS HERE. +! +! LOOP TO COMPUTE ZONAL AND MERIDIONAL GRADIENTS OF PS OR LNPS +! +!sk06162016 DO J=JSTA_2L,JEND_2U +!$omp parallel do private(i,j) + DO J=JSTA,JEND + DO I=ISTA,IEND + PSX(I,J) = SPVAL + PSY(I,J) = SPVAL +!sk PSX(I,J) = D00 +!sk PSY(I,J) = D00 + ENDDO + ENDDO + + CALL EXCH(PS) + +! IF (MODELNAME == 'GFS' .or. global) THEN + CALL EXCH(GDLAT(ISTA_2L,JSTA_2L)) + CALL EXCH(GDLON(ISTA_2L,JSTA_2L)) + + allocate (wrk1(ista:iend,jsta:jend), wrk2(ista:iend,jsta:jend), & + & wrk3(ista:iend,jsta:jend), cosl(ista_2l:iend_2u,jsta_2l:jend_2u)) + allocate(iw(im),ie(im)) + + imb2 = im/2 +!$omp parallel do private(i) + do i=ista,iend + ie(i) = i+1 + iw(i) = i-1 + enddo +! iw(1) = im +! ie(im) = 1 + + +!$omp parallel do private(i,j,ip1,im1) + DO J=JSTA,JEND + do i=ista,iend + ip1 = ie(i) + im1 = iw(i) + cosl(i,j) = cos(gdlat(i,j)*dtr) + if(cosl(i,j) >= SMALL) then + wrk1(i,j) = 1.0 / (ERAD*cosl(i,j)) + else + wrk1(i,j) = 0. + end if + if(i == im .or. i == 1) then + wrk2(i,j) = 1.0 / ((360.+GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam + else + wrk2(i,j) = 1.0 / ((GDLON(ip1,J)-GDLON(im1,J))*DTR) !1/dlam + end if + enddo + ENDDO + + CALL EXCH(cosl) + +!$omp parallel do private(i,j,ii) + DO J=JSTA,JEND + if (j == 1) then + if(gdlat(ista,j) > 0.) then ! count from north to south + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J+1)-GDLAT(II,J))*DTR) !1/dphi + enddo + else ! count from south to north + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J+1)+GDLAT(II,J))*DTR) !1/dphi + enddo + end if + elseif (j == JM) then + if(gdlat(ista,j) < 0.) then ! count from north to south + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + wrk3(i,j) = 1.0 / ((180.+GDLAT(i,J-1)+GDLAT(II,J))*DTR) + enddo + else ! count from south to north + do i=ista,iend + ii = i + imb2 + if (ii > im) ii = ii - im + wrk3(i,j) = 1.0 / ((180.-GDLAT(i,J-1)-GDLAT(II,J))*DTR) + enddo + end if + else + do i=ista,iend + wrk3(i,j) = 1.0 / ((GDLAT(I,J-1)-GDLAT(I,J+1))*DTR) !1/dphi + enddo + endif + ENDDO + +!$omp parallel do private(i,j,ip1,im1,ii,jj) + DO J=JSTA,JEND + IF(J == 1) then ! Near North pole + if(gdlat(ista,j) > 0.) then ! count from north to south + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) + PSY(I,J) = (PS(II,J)-PS(I,J+1))*wrk3(i,j)/ERAD + enddo + ELSE !North pole point, compute at j=2 + jj = 2 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + PSX(I,J) = (PS(ip1,jj)-PS(im1,jj))*wrk2(i,jj)*wrk1(i,jj) + PSY(I,J) = (PS(I,J)-PS(I,jj+1))*wrk3(i,jj)/ERAD + enddo + ENDIF + else + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) + PSY(I,J) = - (PS(II,J)-PS(I,J+1))*wrk3(i,j)/ERAD + enddo + ELSE !North pole point, compute at j=2 + jj = 2 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + PSX(I,J) = (PS(ip1,jj)-PS(im1,jj))*wrk2(i,jj)*wrk1(i,jj) + PSY(I,J) = - (PS(I,J)-PS(I,jj+1))*wrk3(i,jj)/ERAD + enddo + ENDIF + endif + ELSE IF(J == JM) THEN ! Near South pole + if(gdlat(ista,j) < 0.) then ! count from north to south + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) + PSY(I,J) = (PS(I,J-1)-PS(II,J))*wrk3(i,j)/ERAD + enddo + ELSE !South pole point,compute at jm-1 + jj = jm-1 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + PSX(I,J) = (PS(ip1,JJ)-PS(im1,JJ))*wrk2(i,jj)*wrk1(i,jj) + PSY(I,J) = (PS(I,jj-1)-PS(I,J))*wrk3(i,jj)/ERAD + enddo + ENDIF + else + IF(cosl(ista,j) >= SMALL) THEN !not a pole point + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + ii = i + imb2 + if (ii > im) ii = ii - im + PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) + PSY(I,J) = - (PS(I,J-1)-PS(II,J))*wrk3(i,j)/ERAD + enddo + ELSE !South pole point,compute at jm-1 + jj = jm-1 + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + PSX(I,J) = (PS(ip1,JJ)-PS(im1,JJ))*wrk2(i,jj)*wrk1(i,jj) + PSY(I,J) = - (PS(I,jj-1)-PS(I,J))*wrk3(i,jj)/ERAD + enddo + ENDIF + endif + ELSE + DO I=ISTA,IEND + ip1 = ie(i) + im1 = iw(i) + PSX(I,J) = (PS(ip1,J)-PS(im1,J))*wrk2(i,j)*wrk1(i,j) + PSY(I,J) = (PS(I,J-1)-PS(I,J+1))*wrk3(i,j)/ERAD +!sk06142016A + if(PSX(I,J)>100.0)print*,'Debug in CALGRADPS: PSX',i,j,PS(ip1,J),PS(im1,J), & +! print*,'Debug in CALGRADPS',i,j,PS(ip1,J),PS(im1,J), & + & wrk2(i,j),wrk1(i,j),PSX(I,J) + if(PSY(I,J)>100.0)print*,'Debug in CALGRADPS: PSY',i,j,PS(i,J-1),PS(i,J+1), & +! print*,'Debug in CALGRADPS',i,j,PS(i,J-1),PS(i,J+1), & + & wrk3(i,j),ERAD,PSY(I,J) +!-- + ENDDO + END IF +! + ENDDO ! end of J loop + + deallocate (wrk1, wrk2, wrk3, cosl, iw, ie) + +! END IF + + END SUBROUTINE CALGRADPS +! +!------------------------------------------------------------------------------------- ! end module upp_physics + diff --git a/sorc/ncep_post.fd/VRBLS2D_mod.f b/sorc/ncep_post.fd/VRBLS2D_mod.f index aa3231177..569f34ea5 100644 --- a/sorc/ncep_post.fd/VRBLS2D_mod.f +++ b/sorc/ncep_post.fd/VRBLS2D_mod.f @@ -82,7 +82,7 @@ module vrbls2d ,avgesnow(:,:),avgpotevp(:,:),avgprec_cont(:,:),avgcprate_cont(:,:)& ,ti(:,:),aod550(:,:),du_aod550(:,:),ss_aod550(:,:),su_aod550(:,:) & ,bc_aod550(:,:),oc_aod550(:,:),landfrac(:,:),paha(:,:),pahi(:,:) & - ,tecan(:,:),tetran(:,:),tedir(:,:),twa(:,:),fdnsst(:,:) + ,tecan(:,:),tetran(:,:),tedir(:,:),twa(:,:),fdnsst(:,:),pwat(:,:) integer, allocatable :: IVGTYP(:,:),ISLTYP(:,:),ISLOPE(:,:) & ,IEQL(:,:) @@ -95,7 +95,7 @@ module vrbls2d ,SSSMASS(:,:),SSCMASS(:,:),SSSMASS25(:,:),SSCMASS25(:,:) & ,DUSTCB(:,:),SSCB(:,:),OCCB(:,:),BCCB(:,:),SULFCB(:,:) & ,DUSTALLCB(:,:),SSALLCB(:,:),DUSTPM(:,:),SSPM(:,:),PP25CB(:,:) & - ,PP10CB(:,:)!lzhang, add for FV3-Chem + ,DUSTPM10(:,:),PP10CB(:,:),maod(:,:)!lzhang, add for FV3-Chem ! end module vrbls2d diff --git a/sorc/ncep_post.fd/WETBULB.f b/sorc/ncep_post.fd/WETBULB.f index f22ba0368..f63b9c73b 100644 --- a/sorc/ncep_post.fd/WETBULB.f +++ b/sorc/ncep_post.fd/WETBULB.f @@ -8,6 +8,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) ! MODIFIED FOR HYBRID: OCT 2001, H CHUANG ! 02-01-15 MIKE BALDWIN - WRF VERSION ! 21-07-26 Wen Meng - Restrict compuation from undefined grids +! 21-09-13 Jesse Meng- 2D DECOMPOSITION ! !----------------------------------------------------------------------- ! ROUTINE TO COMPUTE WET BULB TEMPERATURES USING THE LOOK UP TABLE @@ -23,7 +24,8 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) use lookup_mod, only: thl, rdth, jtb, qs0, sqs, rdq, itb, ptbl, plq, ttbl,& pl, rdp, the0, sthe, rdthe, ttblq, itbq, jtbq, rdpq, the0q, stheq,& rdtheq - use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval + use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, & + ista, iend, ista_2l, iend_2u use cuparm_mod, only: h10e5, capa, epsq, d00, elocp !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -39,14 +41,14 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) ! SUBROUTINES CALLED: ! TTBLEX ! - real,dimension(IM,jsta_2l:jend_2u,LM),intent(in) :: T,Q, & + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(in) :: T,Q, & PMID,HTM - integer,dimension(IM,jsta:jend), intent(in) :: KARR - real,dimension(IM,jsta_2l:jend_2u,LM),intent(out) :: TWET + integer,dimension(ista:iend,jsta:jend), intent(in) :: KARR + real,dimension(ista_2l:iend_2u,jsta_2l:jend_2u,LM),intent(out) :: TWET - real, dimension(im,jsta:jend) :: THESP, QQ, PP - integer, dimension(im,jsta:jend) :: KLRES,KHRES,IPTB,ITHTB + real, dimension(ista:iend,jsta:jend) :: THESP, QQ, PP + integer, dimension(ista:iend,jsta:jend) :: KLRES,KHRES,IPTB,ITHTB ! integer I,J,L,ITTB1,ITTBK,IQTBK,IT,KNUML,KNUMH,IQ real TBTK,QBTK,APEBTK,TTHBTK,TTHK,QQK,BQS00K,SQS00K,BQS10K, & @@ -62,7 +64,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) !----------------------------------------------------------------------- DO 300 L=1,LM DO 125 J=JSTA,JEND - DO 125 I=1,IM + DO 125 I=ISTA,IEND IF (HTM(I,J,L)<1.0) THEN THESP(I,J)=273.15 cycle @@ -132,7 +134,7 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) KNUMH=0 ! DO 280 J=JSTA,JEND - DO 280 I=1,IM + DO 280 I=ISTA,IEND KLRES(I,J)=0 KHRES(I,J)=0 ! @@ -153,16 +155,16 @@ SUBROUTINE WETBULB(T,Q,PMID,HTM,KARR,TWET) !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE0)THEN - CALL TTBLEX(TWET(1,jsta_2l,L),TTBL,ITB,JTB,KLRES & - ,PMID(1,jsta_2l,L),PL,QQ,PP,RDP,THE0,STHE & + CALL TTBLEX(TWET(ista_2l,jsta_2l,L),TTBL,ITB,JTB,KLRES & + ,PMID(ista_2l,jsta_2l,L),PL,QQ,PP,RDP,THE0,STHE & ,RDTHE,THESP,IPTB,ITHTB) ENDIF !*** !*** COMPUTE PARCEL TEMPERATURE ALONG MOIST ADIABAT FOR PRESSURE>PL !** IF(KNUMH>0)THEN - CALL TTBLEX(TWET(1,jsta_2l,L),TTBLQ,ITBQ,JTBQ,KHRES & - ,PMID(1,jsta_2l,L),PLQ,QQ,PP,RDPQ,THE0Q,STHEQ & + CALL TTBLEX(TWET(ista_2l,jsta_2l,L),TTBLQ,ITBQ,JTBQ,KHRES & + ,PMID(ista_2l,jsta_2l,L),PLQ,QQ,PP,RDPQ,THE0Q,STHEQ & ,RDTHEQ,THESP,IPTB,ITHTB) ENDIF !----------------------------------------------------------------------- diff --git a/sorc/ncep_post.fd/WETFRZLVL.f b/sorc/ncep_post.fd/WETFRZLVL.f index a3aeeede5..63aa39c9e 100644 --- a/sorc/ncep_post.fd/WETFRZLVL.f +++ b/sorc/ncep_post.fd/WETFRZLVL.f @@ -1,52 +1,33 @@ !> @file -! . . . -!> SUBPROGRAM: WETFRZLVL COMPUTES LEVEL OF 0 WET BULB -!! PRGRMMR: MANIKIN ORG: W/NP2 DATE: 03-11-14 -!! -!! ABSTRACT: -!! THIS ROUTINE COMPUTES THE LOWEST HEIGHT WITH A WET BULB -!! TEMPERATURE OF FREEZING FOR EACH MASS POINT ON THE ETA GRID. -!! THE COMPUTED WET BULB ZERO HEIGHT IS THE MEAN SEA LEVEL -!! HEIGHT. AT EACH MASS POINT WE MOVE UP FROM THE SURFACE TO -!! FIND THE FIRST ETA LAYER WHERE THE TW IS LESS THAN -!! 273.16K. VERTICAL INTERPOLATION IN TEMPERATURE TO THE FREEZING -!! TEMPERATURE GIVES THE FREEZING LEVEL HEIGHT. PRESSURE AND -!! SPECIFIC HUMIDITY ARE INTERPOLATED TO THIS LEVEL AND ALONG WITH -!! THE TEMPERATURE PROVIDE THE FREEZING LEVEL RELATIVE HUMIDITY. -!! IF THE SURFACE (SKIN) TEMPERATURE IS BELOW FREEZING, THE ROUTINE -!! USES SURFACE BASED FIELDS TO COMPUTE THE RELATIVE HUMIDITY. -!! -!! PROGRAM HISTORY LOG: -!! 03-11-14 GEOFF MANIKIN - NEW PROGRAM -!! 04-12-06 G MANIKIN - CORRECTED COMPUTATION OF SFC TEMPERATURE -!! 05-03-11 H CHUANG - WRF VERSION -!! 21-07-26 W Meng - Restrict computation from undefined grids -!! -!! USAGE: CALL WETFRZLVL(TWET,ZWET) -!! INPUT ARGUMENT LIST: -!! TWET - WET BULB TEMPERATURES -!! -!! OUTPUT ARGUMENT LIST: -!! ZWET - ABOVE GROUND LEVEL HEIGHT OF LEVEL WITH 0 WET BULB. -!! -!! OUTPUT FILES: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! REL_HUM -!! LIBRARY: -!! COMMON - -!! LOOPS -!! PVRBLS -!! MASKS -!! MAPOT -!! POSTVAR -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN -!! MACHINE : CRAY C-90 -!! +!> @brief wetfrzlvl() computes level of 0 wet bulb. +!> +!> @author Geoff Manikin W/NP2 @date 2003-11-14 + +!> This routine computes the lowest height with a wet bulb +!> temperature of freezing for each mass point on the eta grid. +!> The computed wet bulb zero height is the mean sea level +!> height. At each mass point we move up from the surface to +!> find the first eta layer where the tw is less than +!> 273.16K. Vertical interpolation in temperature to the freezing +!> temperature gives the freezing level height. Pressure and +!> specific humidity are interpolated to this level and along with +!> the temperature provide the freezing level relative humidity. +!> If the surface (skin) temperature is below freezing, the routine +!> uses surface based fields to compute the relative humidity. +!> +!> @param[in] TWET Wet bulb temperatures. +!> @param[out] ZWET Above ground level height of level with 0 wet bulb. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2003-11-14 | Geoff Manikin | Initial +!> 2004-12-06 | Geoff Manikin | Corrected computation of SFC temperature +!> 2005-03-11 | H CHUANG | WRF Version +!> 2021-07-26 | W Meng | Restrict computation from undefined grids +!> 2021-09-13 | J Meng | 2D DECOMPOSITION +!> +!> @author Geoff Manikin W/NP2 @date 2003-11-14 SUBROUTINE WETFRZLVL(TWET,ZWET) ! @@ -55,14 +36,15 @@ SUBROUTINE WETFRZLVL(TWET,ZWET) use vrbls2d, only: fis, thz0, ths use masks, only: lmh, sm use params_mod, only: gi, p1000, capa, tfrz, d0065, d50 - use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval + use ctlblk_mod, only: jsta, jend, im, jsta_2l, jend_2u, lm, spval, & + ista, iend, ista_2l, iend_2u !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! ! DECLARE VARIABLES. ! - REAL,intent(in) :: TWET(IM,JSTA_2L:JEND_2U,LM) - REAL,intent(out) :: ZWET(IM,jsta:jend) + REAL,intent(in) :: TWET(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,LM) + REAL,intent(out) :: ZWET(ista:iend,jsta:jend) ! integer I,J,LLMH,L real HTSFC,THSFC,PSFC,TSFC,DELZ,DELT,ZL,ZU @@ -75,7 +57,7 @@ SUBROUTINE WETFRZLVL(TWET,ZWET) !!$omp& private(delt,delz,htsfc,l,llmh !!$omp& tsfc,zl,zu) DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(FIS(I,J)==spval)THEN ZWET(I,J)=spval CYCLE diff --git a/sorc/ncep_post.fd/WRFPOST.f b/sorc/ncep_post.fd/WRFPOST.f index 571174dd7..c670150f9 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -1,68 +1,35 @@ !> @file -! . . . -!> MAIN PROGRAM: WRFPOST -!! PRGMMR: BALDWIN ORG: NSSL/SPC DATE: 2002-06-18 -!! -!! ABSTRACT: -!! THIS PROGRAM DRIVES THE EXTERNAL WRF POST PROCESSOR. -!! -!! PROGRAM HISTORY LOG: -!! 92-12-24 RUSS TREADON - CODED ETAPOST AS STAND ALONE CODE -!! 98-05-29 BLACK - CONVERSION OF POST CODE FROM 1-D TO 2-D -!! 00-02-04 JIM TUCCILLO - PARALLEL VERSION VIA MPI -!! 01-02-15 JIM TUCCILLO - MANY COMMON BLOCKS REPLACED WITH MODULES -!! TO SUPPORT FORTRAN "ALLOCATE"s FOR THE EXACT SIZE OF THE -!! ARRAYS NEEDED BASED ON THE NUMBER OF MPI TASKS. -!! THIS WAS DONE TO REDUCE THE ADDRESS SPACE THAT THE LOADER SEES. -!! THESE CHANGES WERE NECESSARY FOR RUNNING LARGER DOMAINS SUCH AS -!! 12 KMS -!! 01-06-15 JIM TUCCILLO - ADDED ASYNCRONOUS I/O CAPABILITY. IF THERE ARE MORE -!! THAN ONE MPI TASK, THE IO WILL BE DONE AYNCHRONOUSLY BY THE LAST -!! MPI TASK. -!! 02-06-17 MIKE BALDWIN - CONVERT ETAPOST TO WRFPOST. INCLUDE WRF I/O API -!! FOR INPUT OF MODEL DATA. MODIFY CODE TO DEAL WITH C-GRID -!! DATA. STREAMLINE OUTPUT TO A CALL OF ONE SUBROUTINE INSTEAD OF THREE. -!! REPLACE COMMON BLOCKS WITH A LIMITED NUMBER OF MODULES. -!! 04-01-01 H CHUANG - ADDED NMM IO MODULE AND BINARY OPTIONS -!! 05-07-08 Binbin Zhou: Aadded RSM model -!! 05-12-05 H CHUANG - ADDED CAPABILITY TO OUTPUT OFF-HOUR FORECAST WHICH HAS -!! NO IMPACTS ON ON-HOUR FORECAST -!! 06-02-20 CHUANG, BLACK, AND ROGERS - FINALIZED COMPLETE LIST OF NAM -!! OPERATIONAL PRODUCTS FROM WRF -!! 06-02-27 H CHUANG - MODIFIED TO POST MULTIPLE -!! FORECAST HOURS IN ONE EXECUTION -!! 06-03-03 H CHUANG - ADDED PARRISH'S MPI BINARY IO TO READ BINARY -!! WRF FILE AS RANDOM ASSCESS SO THAT VARIABLES IN WRF OUTPUT -!! DON'T HAVE TO BE READ IN IN SPECIFIC ORDER -!! 11-02-06 J WANG - ADD GRIB2 OPTION -!! 11-12-14 SARAH LU - ADD THE OPTION TO READ NGAC AER FILE -!! 12-01-28 J WANG - Use post available fields in xml file for grib2 -!! 13-06-25 S MOORTHI - add gocart_on logical option to save memory -!! 13-10-03 J WANG - add option for po to be pascal, and -!! add gocart_on,d3d_on and popascal to namelist -!! 20-03-25 J MENG - remove grib1 -!! 21-06-20 W Meng - remove reading grib1 and gfsio lib -!! 21-10-22 KaYee Wong - created formal fortran namelist for itag -!! 21-11-03 Tracy Hertneky - Removed SIGIO option -!! -!! USAGE: WRFPOST -!! INPUT ARGUMENT LIST: -!! NONE -!! -!! OUTPUT ARGUMENT LIST: -!! NONE -!! -!! SUBPROGRAMS CALLED: -!! UTILITIES: -!! NONE -!! LIBRARY: -!! COMMON - CTLBLK -!! RQSTFLD -!! -!! ATTRIBUTES: -!! LANGUAGE: FORTRAN 90 -!! MACHINE : IBM RS/6000 SP -!! +!> @brief wrfpost() drives the external wrf post processor. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 1992-12-24 | Russ Treadon | Coded etapost as stand alone code +!> 1998-05-29 | Black | Conversion of post code from 1-D to 2-D +!> 1900-02-04 | Jim Tuccillo | Parallel version via MPI +!> 2001-02-15 | Jim Tuccillo | Many common blocks replaced with modules to support fortran "allocate"s for the exact size of the arrays needed based on the number of mpi tasks. This was done to reduce the address space that the loader sees. These changes were necessary for running larger domains such as 12 kms +!> 2001-06-15 | JIM Tuccillo | Added asyncronous I/O capability. if there are more than one mpi task, the io will be done aynchronously by the last MPI task. +!> 2002-06-17 | Mike Baldwin | Convert etapost to wrfpost. Include wrf I/O api for input of model data. Modify code to deal with C-grid data. Streamline output to a call of one subroutine instead of three. Replace common blocks with a limited number of modules. +!> 2004-01-01 | H Chuang | Added nmm io module and binary options +!> 2005-07-08 | Binbin Zhou | Added RSM model +!> 2005-12-05 | H Chuang | Added capability to output off-hour forecast which has no impacts on on-hour forecast +!> 2006-02-20 | Chuang, Black, and Rogers | Finalized complete list of NAM operational products from WRF +!> 2006-02-27 | H Chuang | Modified to post multiple forecast hours in one execution +!> 2006-03-03 | H Chuang | Added parrish's mpi binary io to read binary WRF file as random asscess so that variables in WRF output don't have to be read in in specific order +!> 2011-02-06 | J Wang | Add grib2 option +!> 2011-12-14 | Sarah Lu | Add the option to read ngac aer file +!> 2012-01-28 | J WANG | Use post available fields in xml file for grib2 +!> 2013-06-25 | S Moorthi | Add gocart_on logical option to save memory +!> 2013-10-03 | J Wang |Add option for po to be pascal, and add gocart_on,d3d_on and popascal to namelist +!> 2020-03-25 | J Meng | Remove grib1 +!> 2021-06-20 | W Meng | Remove reading grib1 and gfsio lib +!> 2021-07-07 | J MENG |2D DECOMPOSITION +!> 2021-10-22 | KaYee Wong | Created formal fortran namelist for itag +!> 2021-11-03 | Tracy Hertneky | Removed SIGIO option +!> 2022-01-14 | W Meng | Remove interfaces INITPOST_GS_NEMS, INITPOST_NEMS_MPIIO, INITPOST_NMM and INITPOST_GFS_NETCDF +!> 2022-03-15 | W Meng | Unify FV3 based interfaces +!> +!> @author Mike Bladwin NSSL/SPC @date 2002-06-18 PROGRAM WRFPOST ! @@ -142,12 +109,13 @@ PROGRAM WRFPOST use CTLBLK_mod, only: filenameaer, me, num_procs, num_servers, mpi_comm_comp, datestr, & mpi_comm_inter, filename, ioform, grib, idat, filenameflux, filenamed3d, gdsdegr, & spldef, modelname, ihrst, lsmdef,vtimeunits, tprec, pthresh, datahandle, im, jm, lm, & - lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, & + lp1, lm1, im_jm, isf_surface_physics, nsoil, spl, lsmp1, global, imp_physics, & + ista, iend, ista_m, iend_m, ista_2l, iend_2u, & jsta, jend, jsta_m, jend_m, jsta_2l, jend_2u, novegtype, icount_calmict, npset, datapd,& lsm, fld_info, etafld2_tim, eta2p_tim, mdl2sigma_tim, cldrad_tim, miscln_tim, & - mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim, & + mdl2agl_tim, mdl2std_tim, mdl2thandpv_tim, calrad_wcloud_tim, & fixed_tim, time_output, imin, surfce2_tim, komax, ivegsrc, d3d_on, gocart_on,rdaod, & - readxml_tim, spval, fullmodelname, submodelname, hyb_sigp, filenameflat, aqfcmaq_on + readxml_tim, spval, fullmodelname, submodelname, hyb_sigp, filenameflat, aqfcmaq_on,numx use grib2_module, only: gribit2,num_pset,nrecout,first_grbtbl,grib_info_finalize !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none @@ -173,7 +141,7 @@ PROGRAM WRFPOST integer :: kpo,kth,kpv real,dimension(komax) :: po,th,pv namelist/nampgb/kpo,po,kth,th,kpv,pv,fileNameAER,d3d_on,gocart_on,popascal & - ,hyb_sigp,rdaod,aqfcmaq_on,vtimeunits + ,hyb_sigp,rdaod,aqfcmaq_on,vtimeunits,numx integer :: itag_ierr namelist/model_inputs/fileName,IOFORM,grib,DateStr,MODELNAME,SUBMODELNAME & ,fileNameFlux,fileNameFlat @@ -220,6 +188,7 @@ PROGRAM WRFPOST !KaYee: Read itag in Fortran Namelist format !Set default SUBMODELNAME='NONE' + numx=1 !open namelist open(5,file='itag') read(5,nml=model_inputs,iostat=itag_ierr,err=888) @@ -228,6 +197,7 @@ PROGRAM WRFPOST print*,'Incorrect namelist variable(s) found in the itag file,stopping!' stop endif + if (me==0) print*,'fileName= ',fileName if (me==0) print*,'IOFORM= ',IOFORM !if (me==0) print*,'OUTFORM= ',grib @@ -235,6 +205,7 @@ PROGRAM WRFPOST if (me==0) print*,'DateStr= ',DateStr if (me==0) print*,'MODELNAME= ',MODELNAME if (me==0) print*,'SUBMODELNAME= ',SUBMODELNAME + if (me==0) print*,'numx= ',numx ! if(MODELNAME == 'NMM')then ! read(5,1114) VTIMEUNITS ! 1114 format(a4) @@ -272,11 +243,6 @@ PROGRAM WRFPOST ,trim(fileName),trim(fileNameFlux) end if -! -! set ndegr -! if(grib=='grib1') then -! gdsdegr = 1000. -! else if (grib=='grib2') then if(grib=='grib2') then gdsdegr = 1.d6 endif @@ -302,21 +268,51 @@ PROGRAM WRFPOST !set control file name fileNameFlat='postxconfig-NT.txt' -!KaYee if(MODELNAME == 'RAPR') then -!KaYee read(5,*,iostat=iret,end=119) kpo -!KaYee else - read(5,nampgb,iostat=iret,end=119) -!KaYee endif -! if(kpo > komax)print*,'pressure levels cannot exceed ',komax; STOP -! if(kth > komax)print*,'isent levels cannot exceed ',komax; STOP -! if(kpv > komax)print*,'PV levels cannot exceed ',komax; STOP + read(5,nampgb,iostat=iret,end=119) 119 continue + if (me==0) print*,'in itag, mod(num_procs,numx)=', mod(num_procs,numx) + if(mod(num_procs,numx)/=0) then + if (me==0) then + print*,'total proces, num_procs=', num_procs + print*,'number of subdomain in x direction, numx=', numx + print*,'remainder of num_procs/numx = ', mod(num_procs,numx) + print*,'Warning!!! the remainder of num_procs/numx is not 0, reset numx=1 & + & in this run or you adjust numx in the itag file to restart' + endif +! stop 9999 + numx=1 + if(me == 0) print*,'Warning!!! Reset numx as 1, numx=',numx + endif + if(numx>num_procs/2) then + if (me==0) then + print*,'total proces, num_procs=', num_procs + print*,'number of subdomain in x direction, numx=', numx + print*,'Warning!!! numx cannot exceed num_procs/2, reset numx=1 in this run' + print*,'or you adjust numx in the itag file to restart' + endif + numx=1 + if(me == 0) print*,'Warning!!! Reset numx as 1, numx=',numx + endif if(me == 0) then print*,'komax,iret for nampgb= ',komax,iret print*,'komax,kpo,kth,th,kpv,pv,fileNameAER,popascal= ',komax,kpo & & ,kth,th(1:kth),kpv,pv(1:kpv),trim(fileNameAER),popascal + print*,'NUM_PROCS=',NUM_PROCS + print*,'numx= ',numx endif + IF(TRIM(IOFORM) /= 'netcdfpara' .AND. TRIM(IOFORM) /= 'netcdf' ) THEN + numx=1 + if(me == 0) print*,'2D decomposition only supports netcdfpara IO.' + if(me == 0) print*,'Reset numx= ',numx + ENDIF + + IF(MODELNAME /= 'FV3R' .AND. MODELNAME /= 'GFS') THEN + numx=1 + if(me == 0) print*,'2D decomposition only supports GFS and FV3R.' + if(me == 0) print*,'Reset numx= ',numx + ENDIF + ! set up pressure level from POSTGPVARS or DEFAULT if(kpo == 0) then ! use default pressure levels @@ -332,15 +328,6 @@ PROGRAM WRFPOST if(me == 0) then print*,'using pressure levels from POSTGPVARS' endif -!KaYee if(MODELNAME == 'RAPR')then -!KaYee read(5,*) (po(l),l=1,kpo) -! CRA READ VALID TIME UNITS -!KaYee read(5,121) VTIMEUNITS -!KaYee if(me == 0) then -!KaYee print*,'VALID TIME UNITS = ', VTIMEUNITS -!KaYee endif -! CRA -!KaYee endif lsm = kpo if( .not. popascal ) then untcnvt = 100. @@ -360,21 +347,8 @@ PROGRAM WRFPOST LSMP1 = LSM+1 if (me==0) print*,'LSM, SPL = ',lsm,spl(1:lsm) -!Chuang, Jun and Binbin: If model is RSM, read in precip accumulation frequency (sec) from unit5 - if(MODELNAME == 'RSM') then - read(5,115)PRNTSEC - TPREC = PRNTSEC/3600.0 - print*,'TPREC in RSM= ',TPREC - end if - 115 format(f7.1) 116 continue -!KaYee if(MODELNAME == 'GFS') then -! read(5,*) line -!KaYee read(5,111,end=125) fileNameFlat -!KaYee 125 continue -! if(len_trim(fileNameFlat)<5) fileNameFlat = 'postxconfig-NT.txt' -!KaYee if (me == 0) print*,'Post flat name in GFS= ',trim(fileNameFlat) -!KaYee endif + ! set PTHRESH for different models if(MODELNAME == 'NMM')then PTHRESH = 0.000004 @@ -382,7 +356,7 @@ PROGRAM WRFPOST PTHRESH = 0.000001 end if !Chuang: add dynamical allocation - if(TRIM(IOFORM) == 'netcdf') THEN + if(TRIM(IOFORM) == 'netcdf' .OR. TRIM(IOFORM) == 'netcdfpara') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN call ext_ncd_ioinit(SysDepInfo,Status) print*,'called ioinit', Status @@ -426,14 +400,16 @@ PROGRAM WRFPOST call ext_ncd_ioclose ( DataHandle, Status ) ELSE -! use netcdf lib directly to read FV3 output in netCDF +! use parallel netcdf lib directly to read FV3 output in netCDF spval = 9.99e20 - Status = nf90_open(trim(fileName),NF90_NOWRITE, ncid3d) + Status = nf90_open(trim(fileName),IOR(NF90_NOWRITE,NF90_MPIIO), & + ncid3d,comm=mpi_comm_world,info=mpi_info_null) if ( Status /= 0 ) then print*,'error opening ',fileName, ' Status = ', Status stop endif - Status = nf90_open(trim(fileNameFlux),NF90_NOWRITE, ncid2d) + Status = nf90_open(trim(fileNameFlux),IOR(NF90_NOWRITE,NF90_MPIIO), & + ncid2d,comm=mpi_comm_world,info=mpi_info_null) if ( Status /= 0 ) then print*,'error opening ',fileNameFlux, ' Status = ', Status stop @@ -454,6 +430,13 @@ PROGRAM WRFPOST endif if(me==0)print*,'SF_SURFACE_PHYSICS= ',iSF_SURFACE_PHYSICS if(me==0)print*,'NSOIL= ',NSOIL +! read imp_physics + Status=nf90_get_att(ncid2d,nf90_global,'imp_physics',imp_physics) + if(Status/=0)then + print*,'imp_physics not found; assigning to GFDL 11' + imp_physics=11 + endif + if (me == 0) print*,'MP_PHYSICS= ',imp_physics ! get dimesions Status = nf90_inq_dimid(ncid3d,'grid_xt',varid) if ( Status /= 0 ) then @@ -494,53 +477,6 @@ PROGRAM WRFPOST print*,'im jm lm nsoil from fv3 output = ',im,jm,lm,nsoil END IF -! use netcdf_parallel lib directly to read FV3 output in netCDF - ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN - spval = 9.99e20 - Status = nf90_open(trim(fileName),ior(nf90_nowrite, nf90_mpiio), & - ncid3d, comm=mpi_comm_world, info=mpi_info_null) - if ( Status /= 0 ) then - print*,'error opening ',fileName, ' Status = ', Status - stop - endif -! get dimesions - Status = nf90_inq_dimid(ncid3d,'grid_xt',varid) - if ( Status /= 0 ) then - print*,Status,varid - STOP 1 - end if - Status = nf90_inquire_dimension(ncid3d,varid,len=im) - if ( Status /= 0 ) then - print*,Status - STOP 1 - end if - Status = nf90_inq_dimid(ncid3d,'grid_yt',varid) - if ( Status /= 0 ) then - print*,Status,varid - STOP 1 - end if - Status = nf90_inquire_dimension(ncid3d,varid,len=jm) - if ( Status /= 0 ) then - print*,Status - STOP 1 - end if - Status = nf90_inq_dimid(ncid3d,'pfull',varid) - if ( Status /= 0 ) then - print*,Status,varid - STOP 1 - end if - Status = nf90_inquire_dimension(ncid3d,varid,len=lm) - if ( Status /= 0 ) then - print*,Status - STOP 1 - end if - LP1 = LM+1 - LM1 = LM-1 - IM_JM = IM*JM -! set NSOIL to 4 as default for NOAH but change if using other -! SFC scheme - NSOIL = 4 - print*,'im jm lm nsoil from fv3 output = ',im,jm,lm,nsoil ELSE IF(TRIM(IOFORM) == 'binary' .OR. & TRIM(IOFORM) == 'binarympiio' ) THEN @@ -644,28 +580,18 @@ PROGRAM WRFPOST ! Reading model output for different models and IO format - IF(TRIM(IOFORM) == 'netcdf') THEN + IF(TRIM(IOFORM) == 'netcdf' .OR. TRIM(IOFORM) == 'netcdfpara') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR') THEN print*,'CALLING INITPOST TO PROCESS NCAR NETCDF OUTPUT' CALL INITPOST - ELSE IF(MODELNAME == 'NMM') THEN - print*,'CALLING INITPOST_NMM TO PROCESS NMM NETCDF OUTPUT' - CALL INITPOST_NMM - ELSE IF (MODELNAME == 'FV3R') THEN -! use netcdf library to read output directly + ELSE IF (MODELNAME == 'FV3R' .OR. MODELNAME == 'GFS') THEN +! use parallel netcdf library to read output directly print*,'CALLING INITPOST_NETCDF' CALL INITPOST_NETCDF(ncid2d,ncid3d) - ELSE IF (MODELNAME == 'GFS') THEN - print*,'CALLING INITPOST_GFS_NETCDF' - CALL INITPOST_GFS_NETCDF(ncid3d) ELSE PRINT*,'POST does not have netcdf option for model,',MODELNAME,' STOPPING,' STOP 9998 END IF -! use netcdf_parallel library to read fv3 output - ELSE IF(TRIM(IOFORM) == 'netcdfpara') THEN - print*,'CALLING INITPOST_GFS_NETCDF_PARA' - CALL INITPOST_GFS_NETCDF_PARA(ncid3d) ELSE IF(TRIM(IOFORM) == 'binarympiio') THEN IF(MODELNAME == 'NCAR' .OR. MODELNAME == 'RAPR' .OR. MODELNAME == 'NMM') THEN print*,'WRF BINARY IO FORMAT IS NO LONGER SUPPORTED, STOPPING' @@ -680,10 +606,6 @@ PROGRAM WRFPOST ELSE IF(TRIM(IOFORM) == 'binarynemsio') THEN IF(MODELNAME == 'NMM') THEN CALL INITPOST_NEMS(NREC,nfile) - ELSE IF(MODELNAME == 'GFS') THEN -! CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,nfile,ffile) - CALL INITPOST_GFS_NEMS(NREC,iostatusFlux,iostatusD3D,iostatusAER, & - nfile,ffile,rfile) ELSE PRINT*,'POST does not have nemsio option for model,',MODELNAME,' STOPPING,' STOP 9998 @@ -691,11 +613,7 @@ PROGRAM WRFPOST END IF ELSE IF(TRIM(IOFORM) == 'binarynemsiompiio')THEN - IF(MODELNAME == 'NMM') THEN -! close nemsio file for serial read - call nemsio_close(nfile,iret=status) - CALL INITPOST_NEMS_MPIIO() - ELSE IF(MODELNAME == 'GFS') THEN + IF(MODELNAME == 'GFS') THEN ! close nemsio file for serial read call nemsio_close(nfile,iret=status) call nemsio_close(ffile,iret=status) @@ -776,11 +694,15 @@ PROGRAM WRFPOST CALL SET_OUTFLDS(kth,th,kpv,pv) if (me==0) write(0,*)' in WRFPOST size datapd',size(datapd) if(allocated(datapd)) deallocate(datapd) - allocate(datapd(im,1:jend-jsta+1,nrecout+100)) +!Jesse x-decomposition +! allocate(datapd(im,1:jend-jsta+1,nrecout+100)) + allocate(datapd(1:iend-ista+1,1:jend-jsta+1,nrecout+100)) !$omp parallel do private(i,j,k) do k=1,nrecout+100 do j=1,jend+1-jsta - do i=1,im +!Jesse x-decomposition +! do i=1,im + do i =1,iend+1-ista datapd(i,j,k) = 0. enddo enddo diff --git a/sorc/ncep_post.fd/ZENSUN.f b/sorc/ncep_post.fd/ZENSUN.f index a0c0412fb..4c46415b6 100644 --- a/sorc/ncep_post.fd/ZENSUN.f +++ b/sorc/ncep_post.fd/ZENSUN.f @@ -1,75 +1,63 @@ !> @file -! . . . . -!> subprogram: zensun make sun zenith and sun azimuth angle -!! -!! prgmmr: Paul Ricchiazzi org: Earth Space Research Group,UCSB date: 1992-10-23 -!! -!! abstract: -!! Compute solar position information as a function of -!! geographic coordinates, date and time. -!! -!! program history log: -!! 2005-10-21 kazumori - reformatted for GSI -!! -!! input argument list: -!! day - Julian day (positive scalar or vector) -!! (spring equinox = 80) -!! (summer solstice= 171) -!! (fall equinox = 266) -!! (winter solstice= 356) -!! time - Universal Time in hours (scalar or vector) -!! lat - geographic latitude of point on earth's surface (degrees) -!! lon - geographic longitude of point on earth's surface (degrees) -!! -!! output argument list: -!! sun_zenith - solar zenith angle -!! sun_azimuth - solar azimuth angle -!! -!! comments: -!! -!! -!! PROCEDURE: -!! -!! 1. Calculate the subsolar point latitude and longitude, based on -!! DAY and TIME. Since each year is 365.25 days long the exact -!! value of the declination angle changes from year to year. For -!! precise values consult THE AMERICAN EPHEMERIS AND NAUTICAL -!! ALMANAC published yearly by the U.S. govt. printing office. The -!! subsolar coordinates used in this code were provided by a -!! program written by Jeff Dozier. -!! -!! 2. Given the subsolar latitude and longitude, spherical geometry is -!! used to find the solar zenith, azimuth and flux multiplier. -!! -!! eqt = equation of time (minutes) ! solar longitude correction = -15*eqt -!! dec = declination angle (degrees) = solar latitude -!! -!! LOWTRAN v7 data (25 points) -!! The LOWTRAN solar position data is characterized by only 25 points. -!! This should predict the subsolar angles within one degree. For -!! increased accuracy add more data points. -!! -!!nday=[ 1., 9., 21., 32., 44., 60., 91., 121., 141., 152.,$ -!! 160., 172., 182., 190., 202., 213., 244., 274., 305., 309.,$ -!! 325., 335., 343., 355., 366.] -!! -!!eqt=[ -3.23, -6.83,-11.17,-13.57,-14.33,-12.63, -4.2, 2.83, 3.57, 2.45,$ -!! 1.10, -1.42, -3.52, -4.93, -6.25, -6.28,-0.25, 10.02, 16.35, 16.38,$ -!! 14.3, 11.27, 8.02, 2.32, -3.23] -!! -!!dec=[-23.07,-22.22,-20.08,-17.32,-13.62, -7.88, 4.23, 14.83, 20.03, 21.95,$ -!! 22.87, 23.45, 23.17, 22.47, 20.63, 18.23, 8.58, -2.88,-14.18,-15.45,$ -!! -19.75,-21.68,-22.75,-23.43,-23.07] -!! -!! Analemma information from Jeff Dozier -!! This data is characterized by 74 points -!! -!! -!! attributes: -!! language: f90 -!! machine: ibm RS/6000 SP -!! -!! +!> zensun() makes sun zenith and sun azimuth angle. +!> +!> @author Paul Ricchiazzi Earth Space Research Group,UCSB @date 1992-10-23 + +!> This subroutine computes solar position information as a function of +!> geographic coordinates, date and time. +!> +!> +!> @note Procedure: +!> +!> 1. Calculate the subsolar point latitude and longitude, based on +!> DAY and TIME. Since each year is 365.25 days long the exact +!> value of the declination angle changes from year to year. For +!> precise values consult THE AMERICAN EPHEMERIS AND NAUTICAL +!> ALMANAC published yearly by the U.S. govt. printing office. The +!> subsolar coordinates used in this code were provided by a +!> program written by Jeff Dozier. +!> +!> 2. Given the subsolar latitude and longitude, spherical geometry is +!> used to find the solar zenith, azimuth and flux multiplier. +!> +!> eqt = equation of time (minutes) ! solar longitude correction = -15*eqt +!> dec = declination angle (degrees) = solar latitude +!> +!> LOWTRAN v7 data (25 points) +!> The LOWTRAN solar position data is characterized by only 25 points. +!> This should predict the subsolar angles within one degree. For +!> increased accuracy add more data points. +!> +!> nday=[ 1., 9., 21., 32., 44., 60., 91., 121., 141., 152.,$ +!> 160., 172., 182., 190., 202., 213., 244., 274., 305., 309.,$ +!> 325., 335., 343., 355., 366.] +!> +!> eqt=[ -3.23, -6.83,-11.17,-13.57,-14.33,-12.63, -4.2, 2.83, 3.57, 2.45,$ +!> 1.10, -1.42, -3.52, -4.93, -6.25, -6.28,-0.25, 10.02, 16.35, 16.38,$ +!> 14.3, 11.27, 8.02, 2.32, -3.23] +!> +!> dec=[-23.07,-22.22,-20.08,-17.32,-13.62, -7.88, 4.23, 14.83, 20.03, 21.95,$ +!> 22.87, 23.45, 23.17, 22.47, 20.63, 18.23, 8.58, -2.88,-14.18,-15.45,$ +!> -19.75,-21.68,-22.75,-23.43,-23.07] +!> +!> Analemma information from Jeff Dozier +!> +!> This data is characterized by 74 points. +!> +!> +!> @param[in] day Julian day (positive scalar or vector), (spring equinox = 80), (summer solstice= 171), (fall equinox = 266), (winter solstice= 356). +!> @param[in] time Universal Time in hours (scalar or vector). +!> @param[in] lat Geographic latitude of point on earth's surface (degrees). +!> @param[in] lon Geographic longitude of point on earth's surface (degrees). +!> @param[out] sun_zenith - solar zenith angle. +!> @param[out] sun_azimuth - solar azimuth angle. +!> +!> ### Program history log: +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2005-10-21 | kazumori | Reformatted for GSI +!> +!> @author Paul Ricchiazzi Earth Space Research Group,UCSB @date 1992-10-23 subroutine zensun(day,time,lat,lon,pi,sun_zenith,sun_azimuth) ! diff --git a/sorc/ncep_post.fd/build_upp_lib.sh b/sorc/ncep_post.fd/build_upp_lib.sh deleted file mode 100755 index b3a01dae3..000000000 --- a/sorc/ncep_post.fd/build_upp_lib.sh +++ /dev/null @@ -1,54 +0,0 @@ -SHELL=/bin/sh - -module purge -set -x -mac=$(hostname | cut -c1-1) -mac2=$(hostname | cut -c1-2) - -if [ $mac2 = hf ] ; then # For Hera - machine=hera - . /etc/profile - . /etc/profile.d/modules.sh -elif [ $mac = f ] ; then # For Jet - machine=jet - . /etc/profile - . /etc/profile.d/modules.sh -elif [ $mac = v -o $mac = m ] ; then # For Dell - machine=wcoss_dell_p3 - . $MODULESHOME/init/bash -elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS - machine=wcoss - . /usrx/local/Modules/default/init/bash -elif [ $mac2 = s4 ] ; then # For S4 - machine=s4 - . /etc/profile -elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge) - export machine=cray-intel -elif [ $mac = O ] ; then # For Orion - machine=orion - . /etc/profile -fi -export version=${1:-"v8.0.0"} - -moduledir=`dirname $(readlink -f ../../modulefiles/post)` -module use -a ${moduledir} -module load upp/lib-${machine} -#module load nceppost_modulefile - -# -module list - -#sleep 1 - -BASE=`pwd` - -##################################### -cd ${BASE} -rm *.o *.mod incmod -#mkdir -m 775 -p $BASE/../../lib/include/ncep_post_${version}_4 -make -f makefile_lib clean -mkdir -m 775 -p include/upp_4 -make -f makefile_lib - -exit 0 - diff --git a/sorc/ncep_post.fd/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index 35c064c53..bb24fc660 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -10,6 +10,8 @@ module grib2_module ! are defined in xml file ! March, 2015 Lin Gan Replace XML file with flat file implementation ! with parameter marshalling +! July, 2021 Jesse Meng 2D decomsition +! June, 2022 Lin Zhu change the dx/dy to reading in from calculating for latlon grid !------------------------------------------------------------------------ use xml_perl_data, only: param_t,paramset_t ! @@ -197,7 +199,7 @@ end subroutine grib_info_finalize subroutine gribit2(post_fname) ! !------- - use ctlblk_mod, only : im,jm,im_jm,num_procs,me,jsta,jend,ifhr,sdat,ihrst,imin, & + use ctlblk_mod, only : im,jm,im_jm,num_procs,me,ista,iend,jsta,jend,ifhr,sdat,ihrst,imin, & mpi_comm_comp,ntlfld,fld_info,datapd,icnt,idsp implicit none ! @@ -215,6 +217,7 @@ subroutine gribit2(post_fname) integer(4),allocatable :: isdsp(:),iscnt(:),ircnt(:),irdsp(:) integer status(MPI_STATUS_SIZE) integer(kind=MPI_OFFSET_KIND) idisp + integer,allocatable :: ista_pe(:),iend_pe(:) integer,allocatable :: jsta_pe(:),jend_pe(:) integer,allocatable :: grbmsglen(:) real,allocatable :: datafld(:,:) @@ -253,6 +256,12 @@ subroutine gribit2(post_fname) !--- reditribute data from partial domain data with all fields !--- to whole domain data but partial fields ! + allocate(ista_pe(num_procs),iend_pe(num_procs)) + call mpi_allgather(ista,1,MPI_INTEGER,ista_pe,1, & + MPI_INTEGER,MPI_COMM_COMP,ierr) + call mpi_allgather(iend,1,MPI_INTEGER,iend_pe,1, & + MPI_INTEGER,MPI_COMM_COMP,ierr) + allocate(jsta_pe(num_procs),jend_pe(num_procs)) call mpi_allgather(jsta,1,MPI_INTEGER,jsta_pe,1, & MPI_INTEGER,MPI_COMM_COMP,ierr) @@ -269,18 +278,19 @@ subroutine gribit2(post_fname) ! !--- sequatial write if the number of fields to write is small ! - if(minval(nfld_pe)<1.or.num_procs==1) then +!JESSE if(minval(nfld_pe)<1.or.num_procs==1) then + if(num_procs==1) then ! !-- collect data to pe 0 allocate(datafld(im_jm,ntlfld) ) - if(num_procs==1) then +! if(num_procs==1) then datafld=reshape(datapd,(/im_jm,ntlfld/)) - else - do i=1,ntlfld - call mpi_gatherv(datapd(:,:,i),icnt(me),MPI_REAL, & - datafld(:,i),icnt,idsp,MPI_REAL,0,MPI_COMM_COMP,ierr) - enddo - endif +! else +! do i=1,ntlfld +! call mpi_gatherv(datapd(:,:,i),icnt(me),MPI_REAL, & +! datafld(:,i),icnt,idsp,MPI_REAL,0,MPI_COMM_COMP,ierr) +! enddo +! endif ! !-- pe 0 create grib2 message and write to the file if(me==0) then @@ -339,13 +349,13 @@ subroutine gribit2(post_fname) allocate(ircnt(num_procs),irdsp(num_procs)) isdsp(1)=0 do n=1,num_procs - iscnt(n)=(jend_pe(me+1)-jsta_pe(me+1)+1)*im*nfld_pe(n) + iscnt(n)=(jend_pe(me+1)-jsta_pe(me+1)+1)*(iend_pe(me+1)-ista_pe(me+1)+1)*nfld_pe(n) if(n +!> @brief This module is to hold specification kinds for variable declaration. +!> This module is based on (copied from) Paul vanDelst's +!> type_kinds module found in the community radiative transfer model. +!> +!> @note The numerical data types defined in this module are: +!> Variables name | Numerical data types +!> ---------------|------------ +!> i_byte | specification kind for byte (1-byte) integer variable +!> i_short | specification kind for short (2-byte) integer variable +!> i_long | specification kind for long (4-byte) integer variable +!> i_llong | specification kind for double long (8-byte) integer variable +!> r_single | specification kind for single precision (4-byte) real variable +!> r_double | specification kind for double precision (8-byte) real variable +!> r_quad | specification kind for quad precision (16-byte) real variable +!> i_kind | generic specification kind for default integer +!> r_kind | generic specification kind for default floating point +!> +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2004-08-15 | Russ Treadon | Initial +!> +!> @author Russ Treadon np23 @date 2004-08-15 + module kinds implicit none diff --git a/sorc/ncep_post.fd/makefile b/sorc/ncep_post.fd/makefile deleted file mode 100644 index 7a0a614d8..000000000 --- a/sorc/ncep_post.fd/makefile +++ /dev/null @@ -1,258 +0,0 @@ -#!/bin/ksh -set -x -mac=$(hostname | cut -c1-1) -mac2=$(hostname | cut -c1-2) -################################# options ############################################### -#export CLEAN=NO # comment this line to clean before compiling -#debug=YES # turn on debug mode - default - NO - make_post_lib=YES # create post library - default - NO - make_post_exec=YES # create post executable - default - YES -#make_nowrf=YES # compile with wrf stub instead of WRF lib -################################# options ############################################### -# -if [ $mac2 = ga ] ; then # For GAEA - machine=gaea - center=${center:-ncep} - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -elif [ $mac2 = tf ] ; then # For Theia - machine=theia - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -elif [ $mac = z -o $mac = h -o $mac = f ] ; then # For ZEUS - machine=zeus - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -elif [ $mac = t -o $mac = e -o $mac = g ] ; then # For WCOSS - machine=wcoss -elif [ $mac = l -o $mac = s ] ; then # wcoss_c (i.e. luna and surge) - export machine=wcoss_c - make_nowrf=${make_nowrf:-YES} # to compile with wrf stub instead of WRF lib -fi -debug=${debug:-NO} -export make_post_lib=${make_post_lib:-NO} -export make_post_exec=${make_post_exec:-YES} -export make_nowrf=${make_nowrf:- NO} -if [ $machine = wcoss ] ; then - export NETCDFPATH="/usrx/local/NetCDF/3.6.3" - export WRFPATH="/nwprod/sorc/wrf_shared.v1.1.0" - export NWPROD="/nwprod" - export XMLPATH=$NWPROD - export IPPATH=$NWPROD - export SPPATH=/usrx/local/nceplibs - export BACIOPATH=/usrx/local/nceplibs - export ipv="" - export spv=_v2.0.2p - export crtmv=2.0.6 - export crtmv_inc=$crtmv - export xmlv=_v2.0.0 - export baciov=_v2.0.1p - export FC=mpiifort - export CPP="/lib/cpp -P" - export CPPFLAGS="-DLINUX" - export CC=cc - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp " - export DEBUG="-g -traceback -convert big_endian -ftrapuv -check bounds -check format -check output_conversion -check pointers -check uninit -fp-stack-check" - else - export OPTS="-O3 -convert big_endian -fp-model source -openmp -xAVX" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = wcoss_c ] ; then - export FC=ftn - export CPP="/lib/cpp -P" - export CPPFLAGS="-DLINUX" - export CC=cc - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp " - export DEBUG="-g -traceback -convert big_endian -ftrapuv -check bounds -check format -check output_conversion -check pointers -check uninit -fp-stack-check" - else - export OPTS="-O3 -convert big_endian -fp-model source -openmp -xAVX" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = zeus ] ; then - export NETCDFPATH="/apps/netcdf/3.6.3/intel" - export WRFPATH="/scratch2/portfolios/NCEPDEV/meso/save/Dusan.Jovic/WRFV3" - export NWPROD="/contrib/nceplibs/nwprod" - export XMLPATH="/home/Hui-Ya.Chuang" - export IPPATH=$NWPROD - export SPPATH=$NWPROD - export ipv="" - export spv=_v2.0.1 - export crtmv=2.0.7 - export FC="ifort -lmpi" - export CPP="/lib/cpp -P" - export CC=cc - export ARCH="" - export CPPFLAGS="-DLINUX" - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp -g" - export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - else - export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source -openmp" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = theia ] ; then - export NETCDFPATH="/apps/netcdf/4.3.0-intel" - export WRFPATH="/scratch4/NCEPDEV/global/save/Shrinivas.Moorthi/theia/nceplibs/nwprod/lib/sorc/WRFV3" - export NWPROD="/scratch4/NCEPDEV/global/save/Shrinivas.Moorthi/theia/nceplibs/nwprod" - export ipv=_v2.0.3 - export spv="" - export crtmv=2.0.7 - export gfsiov="" - export w3ev=_v2.1.0 - export w3nv="" - export xmlv=_v2.0.0 - export g2tv="" - export baciov=_v2.1.0 - export XMLPATH=$NWPROD - export IPPATH=$NWPROD - export SPPATH=$NWPROD - export BACIOPATH=$NWPROD/lib - export FC=mpiifort - export CPP="/lib/cpp -P" - export CC=cc - export ARCH="" - export CPPFLAGS="-DLINUX" - if [ $debug = YES ] ; then - export OPTS="-O0 -openmp -g" - export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - else - export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source -openmp" - export DEBUG="" - fi - export LIST="" - export FREE="-FR" - export TRAPS="" - export PROFILE="" -elif [ $machine = gaea ] ; then - export NETCDFPATH="/opt/cray/netcdf/4.3.2/INTEL/140" - export WRFPATH="/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod/lib/sorc/WRFV3" - export NWPROD="/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod" - export IPPATH=$NWPROD - export SPPATH=$NWPROD - export baciov=_v2.1.0 - export BACIOPATH=/lustre/f1/unswept/ncep/Shrinivas.Moorthi/nceplibs/nwprod/lib/sorc/bacio_fast_byteswap/bacio${baciov}_4 - export ipv="" - export spv=_v2.0.1 - export xmlv=_v2.0.0 - export FC=ftn - export CPP="/lib/cpp -P" - export ARCH="" - export CPPFLAGS="-DLINUX" - export CC=icc - if [ $debug = YES ] ; then - export OPTS="-O0 -g" - export DEBUG="-g -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursive -traceback" - else - export export OPTS="-O3 -convert big_endian -traceback -g -fp-model source" - export DEBUG="" - fi - export LIST="" - export FREE=-FR - export TRAPS="" - export PROFILE="" - - export gfsiov="" - export crtmv=2.0.7 - export w3ev=_v2.1.0 - export w3nv="" -fi -export crtmv=${crtmv:-2.0.7} -export crtmv_inc=${crtmv_inc:-v$crtmv} -export XMLPATH=${XMLPATH:-$NWPROD} -export BACIOPATH=${BACIOPATH:-$NWPROD/lib} -export xmlv=${xmlv:-""} -export w3ev=${w3ev:-_v2.0.3} -export ipv=${ipv:-""} -export spv=${spv:-""} - -if [ ${CLEAN:-YES} = YES ] ; then make -f Makefile clean ; fi - -export CFLAGS="-DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'" -if [ $machine = wcoss_c ] ; then - - if [ $make_nowrf = YES ] ; then - WRF_INC= - WRF_LIB= - fi - NETCDF_LIB="${NETCDF}/lib/libnetcdf.a" - export FFLAGS="${OPTS} ${FREE} ${TRAPS} ${DEBUG} -I${XMLPARSE_INC} -I${G2_INC4} -I${G2TMPL_INC} -I${NEMSIO_INC} -I${SIGIO_INC4} -I${SFCIO_INC4} -I${GFSIO_INC4} -I${W3EMC_INC4} -I${CRTM_INC} -I${NETCDF_INCLUDE} -I${PNG_INC}" - - export LIBS="${WRF_LIB} ${XMLPARSE_LIB} ${G2_LIB4} ${G2TMPL_LIB} ${NEMSIO_LIB} ${GFSIO_LIB4} ${SIGIO_LIB4} ${SFCIO_LIB4} ${IP_LIB4} ${SP_LIB4} ${W3NCO_LIB4} ${W3EMC_LIB4} ${BACIO_LIB4} ${CRTM_LIB} ${NETCDF_LIB} ${PNG_LIB} ${JASPER_LIB} ${Z_LIB}" -else - SFCIO_INC="-I${NWPROD}/lib/incmod/sfcio_4" - SFCIO_LIB="${NWPROD}/lib/libsfcio_4.a" - - NEMSIO_INC="-I${NWPROD}/lib/incmod/nemsio" - NEMSIO_LIB="-L${NWPROD}/lib -lnemsio" - BACIO_LIB="-L${BACIOPATH} -lbacio${baciov}_4" - SIGIO_INC="-I${NWPROD}/lib/incmod/sigio_4" - SIGIO_LIB="${NWPROD}/lib/libsigio_4.a" - NCDLIBS="-L${NETCDFPATH} -lnetcdf" - NCDFFLAGS="-I${NETCDFPATH}" - if [ $make_nowrf = YES ] ; then - WRF_INC= - WRF_LIB= - else - WRF_INC="-I${WRFPATH}/external/io_quilt -I${WRFPATH}/frame" - WRF_LIB="${WRFPATH}/main/libwrflib.a ${WRFPATH}/frame/pack_utils.o ${WRFPATH}/frame/module_internal_header_util.o ${WRFPATH}/external/io_grib1/libio_grib1.a ${WRFPATH}/external/io_grib_share/libio_grib_share.a ${WRFPATH}/external/io_int/libwrfio_int.a ${WRFPATH}/external/io_netcdf/libwrfio_nf.a ${WRFPATH}/external/esmf_time_f90/libesmf_time.a ${WRFPATH}/external/RSL_LITE/librsl_lite.a" - fi - - G2_INC="-I${NWPROD}/lib/incmod/g2_4 -I${NWPROD}/lib/incmod/g2tmpl${g2tv}" - G2_LIB="-L${NWPROD}/lib -lg2tmpl${g2tv} -lg2_4 -ljasper -lpng -lz" - - GFSIO_INC="-I${NWPROD}/lib/incmod/gfsio${gfsiov}_4" - GFSIO_LIB="-L${NWPROD}/lib -lgfsio${gfsiov}_4" - - IP_LIB="-L${IPPATH}/lib -lip${ipv}_4" - SP_LIB="-L${SPPATH} -lsp${sp}_4" - - W3_INC="-I${NWPROD}/lib/incmod/w3emc${w3ev}_4" - W3_LIB="-L${NWPROD}/lib -lw3nco${w3nv}_4 -lw3emc${w3ev}_4" - - CRTM_INC="-I${NWPROD}/lib/incmod/crtm_${crtmv_inc}" - CRTM_LIB="-L${NWPROD}/lib -lcrtm_v${crtmv}" - XML_INC="-I${XMLPATH}/lib/incmod/xmlparse${xmlv}" - XML_LIB="-L${XMLPATH}/lib -lxmlparse${xmlv}" - - NETCDF_LIB="${NETCDFPATH}/lib/libnetcdf.a" - NETCDF_INC="-I${NETCDFPATH}/include" - - export FFLAGS="${OPTS} ${FREE} ${TRAPS} ${DEBUG} ${WRF_INC} ${XML_INC} ${G2_INC} ${NEMSIO_INC} ${GFSIO_INC} ${SIGIO_INC} ${SFCIO_INC} ${W3_INC} ${CRTM_INC} ${NETCDF_INC}" - - export LIBS="${WRF_LIB} ${XML_LIB} ${G2_LIB} ${NEMSIO_LIB} ${GFSIO_LIB} ${SIGIO_LIB} ${SFCIO_LIB} ${IP_LIB} ${SP_LIB} ${W3_LIB} ${BACIO_LIB} ${CRTM_LIB} ${NETCDF_LIB}" - -fi -if [ $make_post_lib = NO ] ; then - if [ $make_post_exec = YES ] ; then - if [ $make_nowrf = YES ] ; then - _make -f Makefile_nowrf - else - make -f Makefile - fi - fi -else - if [ $make_post_exec = YES ] ; then - if [ $make_nowrf = YES ] ; then - make -f Makefile_nowrf - else - make -f Makefile - fi - fi - export POSTLIBPATH=${POSTLIBPATH:-$(pwd)} - if [ ${CLEAN:-YES} = YES ] ; then rm -rf $POSTLIBPATH/include/post_4 ; fi - mkdir -p $POSTLIBPATH/include/post_4 - make -f Makefile_lib -fi - - diff --git a/sorc/ncep_post.fd/makefile_dtc b/sorc/ncep_post.fd/makefile_dtc deleted file mode 100644 index 519c2418b..000000000 --- a/sorc/ncep_post.fd/makefile_dtc +++ /dev/null @@ -1,130 +0,0 @@ -SHELL = /bin/sh - -################################################################################ -# -# Makefile for NCEP Post -# -# Use: -# make - build the executable -# make clean - start with a clean slate -# -################################################################################# -# -# Define the name of the executable -# -TARGET = unipost.exe - -# -# build configuration determined before compile -include ../../configure.upp - -# -# directories for shared resources -LOCALINC = -I$(INCMOD) -I$(INCMOD)/crtm2 -NCDFINC = -I$(NETCDFPATH)/include -GRIB2INC = -I$(GRIB2SUPT_INC) - -LLIBDIR = -L$(LIBDIR) -UPPLIBS = -lCRTM $(SERIAL_MPI_LIB) -lxmlparse -NCEPLIBS = $(NCEPLIBLIB) $(NCEPLIB_FLAGS) $(GRIB2SUPT_LIB) -NCDFLIBS = -L$(NETCDFPATH)/lib $(NETCDFLIBS) - -LIBS = $(LLIBDIR) $(UPPLIBS) $(GRIB2LIBS) $(NCEPLIBS) $(NCDFLIBS) - -MODULES = - -# -# Compilation / Link Flag Configuration -EXTRA_CPPFLAGS = -EXTRA_FFLAGS = -c $(LOCALINC) $(NETCDFINC) $(NCDFINC) $(NCEPLIBINC) -#EXTRA_LDFLAGS = $(LIBS) -Wl,-Map=lm -EXTRA_LDFLAGS = $(LIBS) -EXTRA_CFLAGS = -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' - -# -# ----------- -# Threaded object files -# ----------- -OBJS_FT = wrf_io_flags.o getVariable.o \ - getIVariableN.o kinds_mod.o machine.o physcons.o \ - native_endianness.o \ - retrieve_index.o ZENSUN.o \ - CLDFRAC_ZHAO.o GFSPOST.o GFSPOSTSIG.o GETGBANDSCATTER.o \ - blockIO.o - -# ----------- -# Non-threaded object files -# ----------- -#OBJXML = post_t.o - -OBJS_F = VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o CMASSI.o \ - CTLBLK.o GRIDSPEC.o \ - LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \ - SET_LVLSXML.o FILL_PSETFLD.o BNDLYR.o BOUND.o CALCAPE.o \ - CALDWP.o CALDRG.o CALHEL.o CALLCL.o CALMCVG.o CALPOT.o CALPW.o CALRH.o CALRCH.o \ - CALRH_GSD.o CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o $(LINUX_OBJ)\ - CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o CALRH_PW.o CALWXT_EXPLICIT.o \ - CALWXT_DOMINANT.o CLDRAD.o \ - CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ - GET_BITS.o INITPOST.o LFMFLD.o MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o ETAMP_Q2F.o \ - MDLFLD.o MPI_FIRST.o MPI_LAST.o NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o \ - EXCH.o PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o READCNTRL.o READ_xml.o \ - SET_OUTFLDS.o SCLFLD.o SERVER.o \ - SETUP_SERVERS.o SMOOTH.o SURFCE.o SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \ - WRFPOST.o CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o ETCALC.o CANRES.o \ - CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o AVIATION.o DEALLOCATE.o \ - CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o CALRH_GFS.o LFMFLD_GFS.o \ - CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o INITPOST_NEMS.o \ - GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \ - GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o MSFPS.o INITPOST_GFS_SIGIO.o\ - AllGETHERV_GSD.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o INITPOST_GFS_NEMS_MPIIO.o \ - INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o \ - gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o CALVESSEL.o \ - CALHEL2.o CALCAPE2.o - -OBJS = $(OBJS_F) $(OBJXML) $(OBJS_FT) - -# ----------- -# Targets -# ----------- -all: $(TARGET) - -$(TARGET): $(XML_DEPS) $(OBJS) $(MODULES) - $(F90) -o $@ $(FFLAGS) $(MODULES) $(OBJS) $(LDFLAGS) $(EXTRA_LDFLAGS) - $(CP) $@ $(BINDIR) - -# This insures a dependency found in some files -- watch file order above remains -- should -# be done w/ dependencies -$(OBJS_F): $(OBJS_FT) $(OBJXML) - -# -# These files are configurable, but rarely change -clean: - @echo -e "\n<><><><> CLEAN <><><><>\n$@ in `pwd`" - $(RM) $(TARGET) $(OBJS) *.lst *.mod - $(RM) $(BINDIR)/$(TARGET) - for f in `ls -1 *.F|sed "s/.F$$/.f/"` ; do \ - $(RM) $$f ; \ - done - -distclean: clean - -.IGNORE: -.PHONY: clean - -.SUFFIXES: -.SUFFIXES: .F .f .f90 .o .c - -.F.o: - $(CPP) $(CPP_FLAGS) $(EXTRA_CPPFLAGS) $< > $*.f - $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $*.f - -.f.o: - $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $< - -.f90.o: - $(F90) -c $(FFLAGS) $(EXTRA_FFLAGS) $< - -.c.o: - ${CC} -c ${CFLAGS} $(EXTRA_CFLAGS) $< - diff --git a/sorc/ncep_post.fd/makefile_lib b/sorc/ncep_post.fd/makefile_lib deleted file mode 100644 index 37d48af6e..000000000 --- a/sorc/ncep_post.fd/makefile_lib +++ /dev/null @@ -1,146 +0,0 @@ -################################################################################ -# -# Makefile for upp (NCEP Post) -# -# Use: -# make - build the executable -# make clean - start with a clean slate -# -# The following macros will be of interest: -# -# TARGET - name of the executable -# FC - name of Fortran compiler -# CPP - name of CPP -# ARCH - architecture -# CPPFLAGS - CPP flags -# OPTS - compiler code optimizations -# LIST - source listing -# SMP - threading -# TRAPS - runtime traps for floating point exceptions -# PROFILE - source code profiling ( -pg ) -# DEBUG - -g -# MEM - user data area and stack size -# MAP - load map -# W3LIB - w3lib -# BACIO - bacio lib -# ESSL - ESSL library -# MASS - MASS library -# HPMLIB - hpm lib -# SEARCH - library search location -# -# This version for eta_post with more intelligent memory allocation -# Jim Tuccillo Feb 2001 -# -# This version for eta_post with asynchronous I/O server. -# Jim Tuccillo June 2001 - -# This version for NEMS_POST -# Jun Wang June 2010 -# -# This version for GFS V16 in-line post -# Wen Meng Ocotomber 2020 -# -################################################################################# -# -# Define the name of the executable -# - #POSTLIBPATH=../.. - #TARGET = ${POSTLIBPATH}/lib/libncep_post_${version}_4.a - #INCMOD= ${POSTLIBPATH}/lib/include/ncep_post_${version}_4 - TARGET = libupp_4.a - INCMOD = include/upp_4 - AR = ar - ARFLAGS = -rv - -# -# CPP, Compiler, and Linker Options -# - -#FC = mpfort -compiler ifort -#CPP = /lib/cpp -P -FC = $(myFC) $(myFCFLAGS) -CPP = $(myCPP) $(myCPPFLAGS) -ARCH = auto -CPPFLAGS = -DLINUX -OPTS = -O -fp-model strict -LIST = -FREE = -FR -#TRAPS = -qflttrap=ov:und:zero:inv:inex -qcheck -qinitauto=FF -TRAPS = -PROFILE = -DEBUG = -g -CFLAGS = -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' -W3LIBDIR = /nwprod/lib - -SEARCH = -# -# Assemble Options -# -#FFLAGS = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(G2_INC4) -I$(G2TMPL_INC) -I$(XMLPARSE_INC) -I$(SIGIO_INC4) -I$(GFSIO_INC4) -FFLAGS = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(G2_INC4) -I$(G2TMPL_INC) -I$(SIGIO_INC4) -I$(GFSIO_INC4) -FFLAGST = $(OPTS) $(FREE) $(TRAPS) $(DEBUG) -I$(CRTM_INC) -I$(W3EMC_INC4) -I$(SIGIO_INC4) -I$(GFSIO_INC4) - -# -# Threaded object files -# -OBJST= kinds_mod.o machine.o physcons.o ZENSUN.o CLDFRAC_ZHAO.o GFSPOST.o -# -# Non-threaded object files -# -#OBJXML= post_t.o -# -OBJS= VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o \ - CMASSI.o CTLBLK.o GRIDSPEC.o LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o \ - cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \ - SET_LVLSXML.o FILL_PSETFLD.o \ - BNDLYR.o BOUND.o CALCAPE.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \ - CALMCVG.o CALPOT.o CALPW.o CALRH.o CALRCH.o CALRH_GSD.o \ - CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \ - CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o CALRH_PW.o \ - CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \ - CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \ - FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ - GET_BITS.o LFMFLD.o \ - MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o \ - NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \ - PARA_RANGE.o PROCESS.o EXCH2.o \ - READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o \ - SMOOTH.o SURFCE.o \ - SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o \ - CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o \ - ETCALC.o CANRES.o CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o \ - AVIATION.o DEALLOCATE.o \ - CALPBL.o MDL2SIGMA2.o CALRH_GFS.o LFMFLD_GFS.o \ - CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \ - ICAOHEIGHT.o \ - GEO_ZENITH_ANGLE.o GFIP3.o GRIDAVG.o CALUPDHEL.o \ - AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o \ - gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \ - CALHEL2.o CALCAPE2.o - - -.SUFFIXES: .F .f .o .f90 .c - -.F.f: - $(CPP) $(CPPFLAGS) $< > $*.f - -$(TARGET): $(OBJST) $(OBJXML) $(OBJS) - $(AR) $(ARFLAGS) $@ $(OBJST) $(OBJXML) $(OBJS) $(LIBS) - mv *.mod $(INCMOD) - -.f.o: - $(FC) $(FFLAGS) -c $< - -.f90.o: - $(FC) $(FFLAGS) -c $< - -.c.o : - ${CC} ${CFLAGS} -c $< - -clean: - /bin/rm -rf libupp_*.a *.lst *.o include -# -#postcntrl_t.o : postcntrl_t.f90 -# $(FC) $(FFLAGS) postcntrl_t.f90 - - diff --git a/sorc/ncep_post.fd/makefile_module b/sorc/ncep_post.fd/makefile_module deleted file mode 100644 index 5b6f2c763..000000000 --- a/sorc/ncep_post.fd/makefile_module +++ /dev/null @@ -1,126 +0,0 @@ -################################################################################################### -# post implement module load standard -# -# 10/15 Lin Gan: Create module load version -# 12/07 Lin Gan: Update to generate post module output -# 07/16 J. Carley: Generalize for multiple machines -# -################################################################################################### - -SHELL=/bin/bash -# -# Define the name of the executable -# -# To generate exe as ncep_post -TARGET = ncep_post -LIB_TARGET = libnceppost.a -AR = ar -ARFLAGS = ruv - -# -# CPP, Compiler, and Linker Options -# - -FC = $(myFC) $(myFCFLAGS) -CPP = $(myCPP) $(myCPPFLAGS) -CPPFLAGS = -DLINUX -FREE = -FR - -NETCDF_INC = -I$(NETCDF)/include -#NETCDF_LDFLAGS = -L$(NETCDF)/lib -lnetcdff -lnetcdf -NETCDF_LDFLAGS = -L$(NETCDF)/lib -lnetcdff -lnetcdf -L$(HDF5_LDFLAGS) $(Z_LIB) - -CFLAGS = -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long' - -FFLAGS = $(OPTS) $(FREE) $(DEBUG) \ - -I$(SFCIO_INC4) \ - -I$(NEMSIO_INC) \ - -I$(SIGIO_INC4) \ - -I$(G2_INC4) \ - -I$(G2TMPL_INC) \ - -I$(GFSIO_INC4) \ - -I$(W3EMC_INC4) \ - -I$(CRTM_INC) \ - -I$(IP_INC4) \ - $(NETCDF_INC) - -LIBS = $(WRFIO_LIB) \ - $(G2TMPL_LIB) \ - $(G2_LIB4) \ - $(JASPER_LIB) \ - $(PNG_LIB) \ - $(Z_LIB) \ - $(NEMSIO_LIB) \ - $(GFSIO_LIB4) \ - $(SIGIO_LIB4) \ - $(SFCIO_LIB4) \ - $(IP_LIB4) \ - $(SP_LIB4) \ - $(W3EMC_LIB4) \ - $(W3NCO_LIB4) \ - $(BACIO_LIB4) \ - $(CRTM_LIB) \ - $(NETCDF_LDFLAGS) - - -OBJS = wrf_io_flags.o getVariable.o getIVariableN.o \ - kinds_mod.o machine.o physcons.o \ - native_endianness.o blockIO.o \ - retrieve_index.o ZENSUN.o CLDFRAC_ZHAO.o \ - GFSPOST.o GFSPOSTSIG.o GETGBANDSCATTER.o \ - VRBLS2D_mod.o VRBLS3D_mod.o VRBLS4D_mod.o MASKS_mod.o PMICRPH.o SOIL_mod.o \ - CMASSI.o CTLBLK.o GRIDSPEC.o LOOKUP.o PARAMR.o RHGRD.o RQSTFLD.o xml_perl_data.o \ - cuparm.o params.o svptbl.o get_postfilename.o grib2_module.o \ - SET_LVLSXML.o FILL_PSETFLD.o \ - UPP_MATH.o UPP_PHYSICS.o \ - BNDLYR.o BOUND.o CALDWP.o CALDRG.o CALHEL.o CALLCL.o \ - CALMCVG.o CALPOT.o CALPW.o CALRCH.o \ - CALSTRM.o CALTAU.o CALTHTE.o CALVIS.o CALVIS_GSD.o CALVOR.o CALWXT.o \ - CALWXT_RAMER.o CALWXT_BOURG.o CALWXT_REVISED.o \ - CALWXT_EXPLICIT.o CALWXT_DOMINANT.o \ - CLDRAD.o CLMAX.o COLLECT.o COLLECT_LOC.o DEWPOINT.o \ - FDLVL.o FGAMMA.o FIXED.o FRZLVL.o FRZLVL2.o \ - GET_BITS.o INITPOST.o LFMFLD.o \ - MAPSSLP.o MISCLN.o MDL2STD_P.o MIXLEN.o MDL2P.o MDLFLD.o MPI_FIRST.o MPI_LAST.o \ - NGMFLD.o NGMSLP.o OTLFT.o OTLIFT.o SLP_new.o SLP_NMM.o EXCH.o \ - PARA_RANGE.o PROCESS.o INITPOST_NMM.o EXCH2.o \ - READCNTRL.o READ_xml.o SET_OUTFLDS.o SCLFLD.o SERVER.o SETUP_SERVERS.o \ - SMOOTH.o SURFCE.o \ - SPLINE.o TABLE.o TABLEQ.o TRPAUS.o TTBLEX.o WETBULB.o WRFPOST.o \ - CALMICT.o MICROINIT.o GPVS.o MDL2SIGMA.o \ - ETCALC.o CANRES.o CALGUST.o WETFRZLVL.o SNFRAC.o MDL2AGL.o SNFRAC_GFS.o \ - AVIATION.o DEALLOCATE.o \ - CALPBL.o MDL2SIGMA2.o INITPOST_GFS.o LFMFLD_GFS.o \ - CALRAD_WCLOUD_newcrtm.o MDL2THANDPV.o CALPBLREGIME.o POLEAVG.o \ - INITPOST_NEMS.o GETNEMSNDSCATTER.o ICAOHEIGHT.o INITPOST_GFS_NEMS.o \ - GEO_ZENITH_ANGLE.o GFIP3.o CALUPDHEL.o INITPOST_GFS_SIGIO.o \ - AllGETHERV_GSD.o MSFPS.o SELECT_CHANNELS.o ALLOCATE_ALL.o INITPOST_NEMS_MPIIO.o ASSIGNNEMSIOVAR.o \ - INITPOST_GFS_NEMS_MPIIO.o INITPOST_NETCDF.o INITPOST_GFS_NETCDF.o INITPOST_GFS_NETCDF_PARA.o \ - gtg_ctlblk.o gtg_indices.o gtg_filter.o gtg_compute.o gtg_config.o map_routines.o gtg_algo.o gtg_smoothseams.o CALVESSEL.o \ - CALHEL2.o ETAMP_Q2F.o - - -.SUFFIXES: .F .f .o .f90 .c - -.F.f: - $(CPP) $(CPPFLAGS) $< > $*.f - -$(TARGET): $(OBJST) $(OBJS) - $(FC) -o $@ $(OBJST) $(OBJS) $(LIBS) $(OPENMP) - mkdir -p include/post_4 - $(AR) $(ARFLAGS) $(LIB_TARGET) $(OBJST) $(OBJS) - mv *.mod include/post_4 - -.f.o: - $(FC) $(FFLAGS) -c $< - -.f90.o: - $(FC) $(FFLAGS) -c $< - -.c.o : - ${CC} ${CFLAGS} -c $< - - -clean: - /bin/rm -f *.o *.mod libnceppost.a ncep_post - /bin/rm -rf include diff --git a/sorc/ncep_post.fd/native_endianness.f b/sorc/ncep_post.fd/native_endianness.f index acfadaacd..c0003e4fe 100644 --- a/sorc/ncep_post.fd/native_endianness.f +++ b/sorc/ncep_post.fd/native_endianness.f @@ -1,35 +1,26 @@ !> @file -! . . . . -!> module: native_endianness -!! prgmmr: parrish org: wx22 date: 2012-10-11 -!! -!! abstract: This module was written by Dusan Jovic and has been adapted to GSI for internal translation -!! of WRF ARW and NMM binary restart files as required to match the machine native -!! endian storage format. The original code only converted from big-endian to little-endian. -!! There are no restrictions in this version. -!! This is required for these two types of files, because they are read/written to using mpi-io, -!! which has no compiler option for automatic switching to machine native endian format -!! for fortran unformatted read/write. -!! -!! program history log: -!! 2012-10-11 parrish - copy/modify original module native_endianness provided by Dusan Jovic, NCEP/EMC 2012 -!! 2012-10-19 parrish - additional modifications to improve efficiency. Remove interface and make -!! to_native_endianness to work only with integer(4) arguments. -!! Put to_native_endianness_i4 outside module. -!! -!! subroutines included: -!! -!! functions included: -!! is_little_endian - no argument--returns true for little-endian machine, false for big-endian machine -!! -!! variables included: -!! byte_swap - false if machine and wrf binary file are same endian, true if different -!! -!! attributes: -!! language: f90 -!! machine: -!! -!! +!> +!> @brief This module, native_endianness, was written by Dusan Jovic and has been adapted to GSI for internal translation +!> of WRF ARW and NMM binary restart files as required to match the machine native +!> endian storage format. The original code only converted from big-endian to little-endian. +!> There are no restrictions in this version. +!> This is required for these two types of files, because they are read/written to using mpi-io, +!> which has no compiler option for automatic switching to machine native endian format +!> for fortran unformatted read/write. +!> +!> @author Parrish wx22 @date 2012-10-11 + +!> @note functions included: is_little_endian - no argument--returns true for little-endian machine, false for big-endian machine +!> +!> @note variables included: byte_swap - false if machine and wrf binary file are same endian, true if different +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2012-10-11 | Parrish | Initial. Copy/modify original module native_endianness provided by Dusan Jovic, NCEP/EMC 2012 +!> 2012-10-19 | parrish | Additional modifications to improve efficiency. Remove interface and make to_native_endianness to work only with integer(4) arguments. Put to_native_endianness_i4 outside module. +!> +!> @author Parrish wx22 @date 2012-10-11 module native_endianness @@ -46,26 +37,14 @@ module native_endianness contains logical function is_little_endian() -!$$$ subprogram documentation block -! . . . . -! subprogram: is_little_endian -! prgmmr: parrish org: wx22 date: 2012-10-11 -! -! abstract: test to see if machine is little-endian. Returns true for little-endian, false for big-endian. -! -! program history log: -! 2012-10-11 parrish - add doc block -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - +!> is_little_endian() tests to see if machine is little-endian. Returns true for little-endian, false for big-endian. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2012-10-11 | Parrish | Add doc block +!> +!> @author Parrish wx22 @date 2012-10-11 implicit none integer(i_byte) :: i1 @@ -86,32 +65,19 @@ end module native_endianness !---------------------------------------------------------------------- subroutine to_native_endianness_i4(i4,num) -!$$$ subprogram documentation block -! . . . . -! subprogram: to_native_endianness_i4 -! prgmmr: parrish org: wx22 date: 2012-10-11 -! -! abstract: swap bytes of argument. -! -! program history log: -! 2012-10-11 parrish - add doc block -! 2012-10-19 parrish - additional modifications to improve efficiency. Remove interface and make -! to_native_endianness to work only with integer(4) arguments. -! Put to_native_endianness_i4 outside module. -! -! input argument list: -! i4 - input 4 byte integer array -! num - length of array i4 (NOTE: type of num must be i_llong (8 byte integer) ) -! -! output argument list: -! i4 - output 4 byte integer array with bytes in reverse order -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - +!> to_native_endianness_i4() is to swap bytes of argument. +!> +!> @param[in] i4 Input 4 byte integer array. +!> @param[in] num Length of array i4. (NOTE: type of num must be i_llong (8 byte integer) ) +!> @param[out] i4 Output 4 byte integer array with bytes in reverse order. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2012-10-11 | Parrish | Add doc block +!> 2012-10-19 | Parrish | Additional modifications to improve efficiency. Remove interface and make to_native_endianness to work only with integer(4) arguments. Put to_native_endianness_i4 outside module. +!> +!> @author Parrish wx22 @date 2012-10-11 use kinds, only: i_byte,i_long,i_llong implicit none diff --git a/sorc/ncep_post.fd/post_gtg.fd b/sorc/ncep_post.fd/post_gtg.fd new file mode 160000 index 000000000..b7e077699 --- /dev/null +++ b/sorc/ncep_post.fd/post_gtg.fd @@ -0,0 +1 @@ +Subproject commit b7e077699ca1054104cc93342a038941346bef04 diff --git a/sorc/ncep_post.fd/retrieve_index.f b/sorc/ncep_post.fd/retrieve_index.f index ebacab31a..1fb390378 100644 --- a/sorc/ncep_post.fd/retrieve_index.f +++ b/sorc/ncep_post.fd/retrieve_index.f @@ -1,31 +1,22 @@ !> @file -! . . . . -!> subprogram: retrieve_index get record number of desired variable -!! prgmmr: parrish org: np22 date: 2004-11-29 -!! -!! abstract: by examining previously generated inventory of wrf binary restart file, -!! find record number that contains the header record for variable -!! identified by input character variable "string". -!! -!! program history log: -!! 2004-11-29 parrish -!! -!! input argument list: -!! string - mnemonic for variable desired -!! varname_all - list of all mnemonics obtained from inventory of file -!! nrecs - total number of sequential records counted in wrf -!! binary restart file -!! -!! output argument list: -!! index - desired record number -!! iret - return status, set to 0 if variable was found, -!! non-zero if not. -!! -!! attributes: -!! language: f90 -!! machine: ibm RS/6000 SP -!! -!! +!> @brief retrieve_index() gets record number of desired variable. +!> +!> By examining previously generated inventory of wrf binary restart file, +!> find record number that contains the header record for variable +!> identified by input character variable "string". +!> +!> @param[in] string Mnemonic for variable desired. +!> @param[in] varname_all List of all mnemonics obtained from inventory of file. +!> @param[in] nrecs Total number of sequential records counted in wrf binary restart file. +!> @param[out] index Desired record number. +!> @param[out] iret Return status, set to 0 if variable was found, non-zero if not. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2004-11-29 | Parrish | Initial +!> +!> @author Parrish np22 @date 2004-11-29 subroutine retrieve_index(index,string,varname_all,nrecs,iret) diff --git a/tests/compile_upp.sh b/tests/compile_upp.sh index 94360f243..2c20f660c 100755 --- a/tests/compile_upp.sh +++ b/tests/compile_upp.sh @@ -1,13 +1,53 @@ #!/bin/bash # Wen Meng 01/2020, Set up for cmake build. -############################################# +# Wen Meng 01/2022, Add option for building with gtg code +############################################################ -set -x +set -eu -#Clean loaded modules -module purge +usage() { + echo + echo "Usage: $0 [-p] [-g] [-w] [-v] [-c] -h" + echo + echo " -p installation prefix DEFAULT: ../install" + echo " -g build with GTG(users with gtg repos. access only) DEFAULT: OFF" + echo " -w build without WRF-IO DEFAULT: ON" + echo " -v build with cmake verbose DEFAULT: NO" + echo " -c Compiler to use for build DEFAULT: intel" + echo " -h display this message and quit" + echo + exit 1 +} + +prefix="../install" +gtg_opt=" -DBUILD_WITH_GTG=OFF" +wrfio_opt=" -DBUILD_WITH_WRFIO=ON" +compiler="intel" +verbose_opt="" +while getopts ":p:gwc:vh" opt; do + case $opt in + p) + prefix=$OPTARG + ;; + g) + gtg_opt=" -DBUILD_WITH_GTG=ON" + ;; + w) + wrfio_opt=" -DBUILD_WITH_WRFIO=OFF" + ;; + c) + compiler=$OPTARG + ;; + v) + verbose_opt="VERBOSE=1" + ;; + h|\?|:) + usage + ;; + esac +done +cmake_opts=" -DCMAKE_INSTALL_PREFIX=$prefix"${wrfio_opt}${gtg_opt} -hostname source ./detect_machine.sh if [[ $(uname -s) == Darwin ]]; then readonly MYDIR=$(cd "$(dirname "$(greadlink -f -n "${BASH_SOURCE[0]}" )" )" && pwd -P) @@ -17,15 +57,32 @@ fi PATHTR=${PATHTR:-$( cd ${MYDIR}/.. && pwd )} #Load required modulefiles -module use $PATHTR/modulefiles -modulefile=${MACHINE_ID} -module load $modulefile -module list +if [[ $MACHINE_ID != "unknown" ]]; then + if [[ $MACHINE_ID == "wcoss2" ]]; then + module reset + else + module purge + fi + module use $PATHTR/modulefiles + if [[ $compiler == "intel" ]]; then + modulefile=${MACHINE_ID} + else + modulefile=${MACHINE_ID}_${compiler} + fi + if [ -f "${PATHTR}/modulefiles/${modulefile}" -o -f "${PATHTR}/modulefiles/${modulefile}.lua" ]; then + echo "Building for machine ${MACHINE_ID}, compiler ${compiler}" + else + echo "Modulefile does not exist for machine ${MACHINE_ID}, compiler ${compiler}" + exit 1 + fi + module load $modulefile + module list +fi rm -rf build install mkdir build && cd build -cmake -DCMAKE_INSTALL_PREFIX=../install -DBUILD_WITH_WRFIO=ON ../.. -make -j6 +cmake $cmake_opts ../.. +make -j6 $verbose_opt make install rm -rf $PATHTR/exec && mkdir $PATHTR/exec diff --git a/tests/detect_machine.sh b/tests/detect_machine.sh index 9362e5635..7620dc004 100755 --- a/tests/detect_machine.sh +++ b/tests/detect_machine.sh @@ -16,6 +16,12 @@ case $(hostname -f) in v72a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus v72a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus v72a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus + v109a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus + v109a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus + v109a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus + v110a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus + v110a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus + v110a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### venus m71a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars m71a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars @@ -23,9 +29,35 @@ case $(hostname -f) in m72a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars m72a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars m72a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars - - alogin01) MACHINE_ID=wcoss2 ;; ### acorn - alogin02) MACHINE_ID=wcoss2 ;; ### acorn + m109a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars + m110a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars + m109a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars + m110a1.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars + m110a2.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars + m110a3.ncep.noaa.gov) MACHINE_ID=wcoss_dell_p3 ;; ### mars + + alogin01.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2_a ;; ### acorn + alogin02.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2_a ;; ### acorn + adecflow01.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn + adecflow02.acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn + dlogin01.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin02.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin03.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin04.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin05.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin06.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin07.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin08.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + dlogin09.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dodwood + clogin01.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin02.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin03.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin04.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin05.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin06.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin07.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin08.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus + clogin09.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus gaea9) MACHINE_ID=gaea ;; ### gaea9 gaea10) MACHINE_ID=gaea ;; ### gaea10 @@ -92,6 +124,8 @@ case $(hostname -f) in login4.stampede2.tacc.utexas.edu) MACHINE_ID=stampede ;; ### stampede4 s4-submit.ssec.wisc.edu) MACHINE_ID=s4 ;; ### S4 + + *) MACHINE_ID=unknown esac # Overwrite auto-detect with RT_MACHINE if set diff --git a/ush/fv3gfs_downstream_nems.sh b/ush/fv3gfs_downstream_nems.sh index b2f625de3..149b02021 100755 --- a/ush/fv3gfs_downstream_nems.sh +++ b/ush/fv3gfs_downstream_nems.sh @@ -99,7 +99,7 @@ fi #----------------------------------------------------- #----------------------------------------------------- -if [ $machine = WCOSS -o $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 -o $machine = HERA -o $machine = ORION -o $machine = JET -o $machine = S4 ]; then +if [ $machine = WCOSS -o $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 -o $machine = HERA -o $machine = ORION -o $machine = JET -o $machine = S4 -o $machine = WCOSS2 ]; then #----------------------------------------------------- #----------------------------------------------------- export nset=1 @@ -171,7 +171,7 @@ date export MP_PGMMODEL=mpmd export MP_CMDFILE=$DATA/poescript launcher=${APRUN_DWN:-"aprun -j 1 -n 24 -N 24 -d 1 cfp"} - if [ $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 ] ; then + if [ $machine = WCOSS_C -o $machine = WCOSS_DELL_P3 -o $machine = WCOSS2 ] ; then $launcher $MP_CMDFILE elif [ $machine = HERA -o $machine = ORION -o $machine = JET -o $machine = S4 ] ; then if [ -s $DATA/poescript_srun ]; then rm -f $DATA/poescript_srun; fi diff --git a/ush/gfs_nceppost.sh b/ush/gfs_nceppost.sh index 975bdc6a6..2ee5afcde 100755 --- a/ush/gfs_nceppost.sh +++ b/ush/gfs_nceppost.sh @@ -23,6 +23,8 @@ # Remove legacy setting for reading non-nemsio model output # and generating grib1 data # 2019-06-02 Wen Meng: Remove the links of gfs fix files. +# 2021-06-11 Yali Mao: Instead of err_chk, 'exit $err' for wafsfile +# if POSTGPEXEC fails # # Usage: global_postgp.sh SIGINP FLXINP FLXIOUT PGBOUT PGIOUT IGEN # @@ -292,7 +294,7 @@ export pgm=$PGM $LOGSCRIPT cat <postgp.inp.nml$$ &NAMPGB - $POSTGPVARS + $POSTGPVARS numx=2 EOF cat <>postgp.inp.nml$$ @@ -351,6 +353,12 @@ ${APRUN:-mpirun.lsf} $POSTGPEXEC < itag > outpost_gfs_${VDATE}_${CTL} export ERR=$? export err=$ERR + +if [ $err -ne 0 ] ; then + if [ $PGBOUT = "wafsfile" ] ; then + exit $err + fi +fi $ERRSCRIPT||exit 2 if [ $FILTER = "1" ] ; then