diff --git a/VERSION b/VERSION index fe46e0dd3..275283a18 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -10.2.0 \ No newline at end of file +11.0.0 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/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/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f index 75d6bfc64..a93741328 100644 --- a/sorc/ncep_post.fd/ALLOCATE_ALL.f +++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f @@ -47,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 @@ -88,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 @@ -96,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 @@ -122,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 @@ -131,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 @@ -194,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 @@ -226,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 @@ -281,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 @@ -309,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)) @@ -319,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 @@ -336,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 @@ -372,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 @@ -422,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 @@ -506,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 @@ -523,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 @@ -550,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 @@ -569,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 @@ -621,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 @@ -675,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 @@ -726,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 @@ -784,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 @@ -845,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 @@ -925,57 +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(pwat(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 @@ -1028,19 +1028,19 @@ SUBROUTINE ALLOCATE_ALL() ! ! 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 @@ -1058,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 @@ -1080,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 @@ -1090,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 @@ -1100,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 @@ -1110,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 @@ -1119,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 @@ -1135,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 @@ -1175,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 @@ -1186,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 @@ -1198,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 @@ -1210,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 @@ -1219,54 +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(dustpm10(im,jsta_2l:jend_2u)) - allocate(sspm(im,jsta_2l:jend_2u)) - allocate(maod(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 @@ -1304,13 +1304,13 @@ SUBROUTINE ALLOCATE_ALL() 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 @@ -1318,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 @@ -1335,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 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 !> !> @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 ! @@ -44,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 c06db3e7a..352d6cf59 100644 --- a/sorc/ncep_post.fd/CALDRG.f +++ b/sorc/ncep_post.fd/CALDRG.f @@ -27,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 @@ -35,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 @@ -47,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 @@ -57,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 @@ -91,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. @@ -128,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. @@ -174,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 be3876bd0..02f309a94 100644 --- a/sorc/ncep_post.fd/CALDWP.f +++ b/sorc/ncep_post.fd/CALDWP.f @@ -24,16 +24,16 @@ 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 ! !**************************************************************************** @@ -43,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) 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 @@ -24,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 @@ -35,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 @@ -51,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 110e5b049..a69c4260b 100644 --- a/sorc/ncep_post.fd/CALHEL.f +++ b/sorc/ncep_post.fd/CALHEL.f @@ -36,6 +36,7 @@ !> 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) @@ -47,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 @@ -65,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 @@ -83,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) @@ -103,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 @@ -143,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 @@ -154,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 @@ -165,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 @@ -181,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 2cddefbb4..2c1bb8460 100644 --- a/sorc/ncep_post.fd/CALHEL2.f +++ b/sorc/ncep_post.fd/CALHEL2.f @@ -39,6 +39,7 @@ !> 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) @@ -50,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 @@ -68,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) ! @@ -91,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) @@ -110,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 @@ -153,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 @@ -164,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 @@ -175,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 @@ -191,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 839082b2e..156911f17 100644 --- a/sorc/ncep_post.fd/CALHEL3.f +++ b/sorc/ncep_post.fd/CALHEL3.f @@ -39,6 +39,7 @@ !> 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) @@ -50,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 @@ -68,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) ! @@ -89,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) @@ -108,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 @@ -149,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 @@ -160,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 @@ -171,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 @@ -187,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 8a3fbfb75..6cc377511 100644 --- a/sorc/ncep_post.fd/CALLCL.f +++ b/sorc/ncep_post.fd/CALLCL.f @@ -25,6 +25,7 @@ !> 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) @@ -35,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 ! @@ -44,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 ! @@ -57,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 @@ -69,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) 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) @@ -38,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 ! !*************************************************************************** @@ -60,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) 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, & @@ -37,7 +38,8 @@ SUBROUTINE CALMICT_new(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & ! 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 @@ -49,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 @@ -67,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. @@ -81,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 @@ -333,7 +335,8 @@ SUBROUTINE CALMICT_old(P1D,T1D,Q1D,C1D,FI1D,FR1D,FS1D,CUREFL, & !> !> @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, & @@ -344,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 @@ -361,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. @@ -375,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 1b18e6f54..015f4cd10 100644 --- a/sorc/ncep_post.fd/CALPBL.f +++ b/sorc/ncep_post.fd/CALPBL.f @@ -10,6 +10,7 @@ !> 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) @@ -19,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 @@ -42,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 @@ -58,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) 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) @@ -32,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 @@ -43,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, & @@ -57,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 @@ -84,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) 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 ! @@ -29,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 ! @@ -41,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 b63e9ce1f..dced136ca 100644 --- a/sorc/ncep_post.fd/CALPW.f +++ b/sorc/ncep_post.fd/CALPW.f @@ -35,6 +35,7 @@ !> 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) @@ -46,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 @@ -63,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. @@ -75,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 @@ -89,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 @@ -132,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 @@ -141,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 @@ -153,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 @@ -165,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 @@ -173,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 @@ -181,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 @@ -189,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 @@ -197,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 @@ -205,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) @@ -215,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 @@ -224,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 @@ -234,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 @@ -244,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 @@ -253,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 @@ -262,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 @@ -270,7 +271,7 @@ 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) 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 !> !> @author Chuang @date 2007-01-17 SUBROUTINE CALRAD_WCLOUD @@ -50,7 +51,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 @@ -175,7 +176,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 @@ -352,7 +353,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 @@ -616,7 +617,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 - '// & @@ -699,7 +700,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 @@ -1137,14 +1138,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 @@ -1155,14 +1156,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 @@ -1174,14 +1175,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 @@ -1193,14 +1194,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 @@ -1212,14 +1213,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 @@ -1253,7 +1254,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 @@ -1713,14 +1714,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 @@ -1735,14 +1736,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 @@ -1757,14 +1758,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 @@ -1780,14 +1781,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 @@ -1799,14 +1800,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 @@ -1820,14 +1821,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 @@ -1842,14 +1843,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 @@ -1864,14 +1865,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 @@ -1884,14 +1885,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 @@ -1903,14 +1904,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 @@ -1922,14 +1923,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 @@ -1940,14 +1941,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 @@ -1958,14 +1959,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 @@ -1979,14 +1980,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 @@ -2001,14 +2002,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 @@ -2023,14 +2024,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 @@ -2043,14 +2044,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 @@ -2062,14 +2063,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 @@ -2079,14 +2080,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 e923fa53a..b1b520aed 100644 --- a/sorc/ncep_post.fd/CALRCH.f +++ b/sorc/ncep_post.fd/CALRCH.f @@ -18,6 +18,7 @@ !> 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) @@ -27,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 @@ -48,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 @@ -65,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 @@ -90,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 311f6fbc4..adf7ac43e 100644 --- a/sorc/ncep_post.fd/CALSTRM.f +++ b/sorc/ncep_post.fd/CALSTRM.f @@ -19,6 +19,7 @@ !> 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) @@ -31,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 ! @@ -40,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 @@ -59,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 1d351a3c0..08338039d 100644 --- a/sorc/ncep_post.fd/CALTAU.f +++ b/sorc/ncep_post.fd/CALTAU.f @@ -21,6 +21,7 @@ !> 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 @@ -33,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 @@ -41,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 @@ -53,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. ! @@ -63,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 @@ -80,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) 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 @@ -25,7 +26,7 @@ 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 ! @@ -37,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, & @@ -50,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 @@ -58,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) 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) @@ -22,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 @@ -34,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 @@ -47,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 @@ -73,13 +75,13 @@ 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 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 -!> @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 -!> -!> @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 - 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) 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 - use gridspec_mod, only: gridtype - - implicit none -! -! DECLARE VARIABLES. -! - REAL, dimension(im,jsta_2l:jend_2u,lm), intent(in) :: UWND,VWND - REAL, dimension(im,jsta:jend,lm), intent(inout) :: DIV -! - 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(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 - - 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) -!> 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 - 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 fa584b8b5..51fb0a3d0 100644 --- a/sorc/ncep_post.fd/CALWXT_BOURG.f +++ b/sorc/ncep_post.fd/CALWXT_BOURG.f @@ -44,27 +44,29 @@ !> 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 @@ -83,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 @@ -103,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 26c375205..fb03d8752 100644 --- a/sorc/ncep_post.fd/CLDRAD.f +++ b/sorc/ncep_post.fd/CLDRAD.f @@ -99,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 @@ -116,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, & @@ -136,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, & @@ -147,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 --- @@ -193,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(:,:,:) @@ -201,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 @@ -245,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 @@ -255,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 @@ -272,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 @@ -287,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 @@ -316,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 @@ -324,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 @@ -344,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 @@ -358,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 @@ -366,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 @@ -392,7 +397,7 @@ SUBROUTINE CLDRAD GRID1 = spval Model_Pwat = .false. DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND IF(ABS(PWAT(I,J)-SPVAL)>SMALL) THEN Model_Pwat = .true. exit @@ -401,14 +406,14 @@ SUBROUTINE CLDRAD END DO IF (Model_Pwat) THEN DO J=JSTA,JEND - DO I=1,IM + DO I=ISTA,IEND GRID1(I,J) = PWAT(I,J) END DO END DO ELSE - CALL CALPW(GRID1(1,jsta),1) + 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 @@ -417,11 +422,12 @@ SUBROUTINE CLDRAD 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 @@ -431,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 @@ -450,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 @@ -471,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 @@ -568,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 @@ -586,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 @@ -604,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 @@ -621,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 @@ -638,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 @@ -655,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 @@ -671,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 @@ -687,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 @@ -725,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 @@ -737,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 @@ -775,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 @@ -787,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 @@ -824,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 @@ -858,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 @@ -887,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 ! @@ -906,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. @@ -923,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 @@ -1009,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 @@ -1023,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 ! @@ -1031,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 @@ -1042,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 @@ -1056,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 @@ -1092,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 @@ -1107,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 @@ -1118,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 @@ -1132,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 @@ -1168,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 @@ -1183,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 @@ -1194,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 @@ -1209,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 @@ -1245,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 @@ -1261,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 @@ -1273,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))* & @@ -1285,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 @@ -1296,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 @@ -1313,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 @@ -1324,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 @@ -1375,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 @@ -1391,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. @@ -1433,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 ! @@ -1443,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. @@ -1485,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 ! @@ -1503,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 ! @@ -1634,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 ! @@ -1653,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 @@ -1684,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 @@ -1734,7 +1768,8 @@ 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 @@ -1919,7 +1954,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 @@ -1930,14 +1965,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 @@ -1955,7 +1990,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. @@ -2021,14 +2056,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 @@ -2052,7 +2087,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 @@ -2170,16 +2205,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) @@ -2207,14 +2249,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 @@ -2222,14 +2264,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 @@ -2240,32 +2282,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 @@ -2277,13 +2320,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) @@ -2296,11 +2339,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 @@ -2310,7 +2354,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) @@ -2322,14 +2366,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) @@ -2341,14 +2385,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) @@ -2360,7 +2404,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 @@ -2368,7 +2412,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 @@ -2404,14 +2448,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 @@ -2447,14 +2491,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 @@ -2490,7 +2534,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 ! @@ -2503,7 +2547,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 @@ -2571,7 +2615,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. @@ -2635,28 +2679,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 @@ -2665,14 +2709,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 ! @@ -2681,7 +2725,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 @@ -2773,7 +2817,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 @@ -2784,13 +2828,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) @@ -2803,11 +2847,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 @@ -2817,7 +2862,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) @@ -2829,14 +2874,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) @@ -2848,7 +2893,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 ! @@ -2856,7 +2901,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) @@ -2868,7 +2913,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 @@ -2876,7 +2921,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 @@ -2912,14 +2957,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 @@ -2951,14 +2996,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 @@ -2990,7 +3035,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 @@ -2998,7 +3043,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 @@ -3030,14 +3075,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 @@ -3069,14 +3114,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 @@ -3107,7 +3152,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 ! @@ -3116,7 +3161,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 @@ -3124,13 +3169,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 @@ -3140,7 +3185,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 @@ -3172,7 +3217,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 ! @@ -3180,7 +3225,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 @@ -3212,7 +3257,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 ! @@ -3232,7 +3277,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 @@ -3268,7 +3313,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 ! @@ -3285,7 +3330,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 @@ -3322,7 +3367,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 ! @@ -3339,7 +3384,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 @@ -3376,7 +3421,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 ! @@ -3392,7 +3437,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 @@ -3428,7 +3473,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 ! @@ -3444,7 +3489,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 @@ -3480,7 +3525,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 ! @@ -3496,7 +3541,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 @@ -3532,7 +3577,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 ! @@ -3548,7 +3593,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 @@ -3584,7 +3629,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 ! @@ -3600,7 +3645,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 @@ -3636,7 +3681,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 ! @@ -3646,7 +3691,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 @@ -3654,7 +3699,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 ! @@ -3665,7 +3710,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 @@ -3674,7 +3719,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 ! @@ -3682,7 +3727,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) @@ -3697,7 +3742,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 ! @@ -3706,7 +3751,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 @@ -3727,7 +3772,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 ! @@ -3736,7 +3781,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) @@ -3751,21 +3796,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 @@ -3773,42 +3818,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 @@ -3816,7 +3861,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 @@ -3824,7 +3869,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 @@ -3833,7 +3878,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) @@ -3847,21 +3892,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 @@ -3869,28 +3914,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 @@ -3898,35 +3943,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 @@ -3957,14 +4002,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 @@ -3995,28 +4040,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 @@ -4047,14 +4092,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 @@ -4085,14 +4130,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 @@ -4123,14 +4168,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 @@ -4161,14 +4206,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 @@ -4199,14 +4244,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 @@ -4239,14 +4284,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 @@ -4278,14 +4323,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 @@ -4317,14 +4362,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 @@ -4356,7 +4401,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 @@ -4364,80 +4409,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 @@ -4445,42 +4490,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 ! @@ -4666,14 +4711,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) @@ -4681,7 +4726,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) @@ -4769,7 +4814,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) @@ -4796,7 +4841,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 @@ -4830,7 +4875,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 @@ -4863,7 +4908,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 @@ -4895,7 +4940,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 @@ -4925,7 +4970,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) @@ -4957,7 +5002,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 @@ -4966,7 +5011,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 @@ -4977,7 +5022,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 @@ -4985,7 +5030,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 ! @@ -4997,7 +5042,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) @@ -5012,7 +5057,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) @@ -5021,7 +5066,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) @@ -5036,7 +5081,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' @@ -5052,7 +5097,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 @@ -5060,7 +5105,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 @@ -5071,7 +5116,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) @@ -5083,7 +5128,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 @@ -5092,7 +5137,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) @@ -5104,7 +5149,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 @@ -5119,9 +5164,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 @@ -5129,13 +5174,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 @@ -5146,7 +5191,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 ! 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 @@ -5232,7 +5277,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 @@ -5240,7 +5285,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 @@ -5248,28 +5293,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 = 1,IM + 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: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 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 @@ -5283,7 +5328,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 @@ -5291,7 +5336,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 @@ -5299,14 +5344,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 @@ -5314,7 +5359,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 @@ -5322,7 +5367,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 @@ -5330,7 +5375,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) ! @@ -5338,7 +5383,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) 300.*100) then @@ -5577,17 +5622,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 @@ -5595,17 +5641,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 @@ -5613,17 +5660,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 @@ -5639,9 +5687,9 @@ 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 + 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 @@ -5661,7 +5709,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. @@ -5692,20 +5740,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) Gather "A" from all MPI tasks onto task 0. !> !> ### Program history log: -!> Date | Programmer | Comments -!> -----|------------|--------- -!> 2000-01-06 | Jim Tuccillo | Initial +!> 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 10fac93fa..ac9d5c648 100644 --- a/sorc/ncep_post.fd/DEALLOCATE.f +++ b/sorc/ncep_post.fd/DEALLOCATE.f @@ -187,6 +187,7 @@ SUBROUTINE DE_ALLOCATE deallocate(tsnow) deallocate(qvg) deallocate(qv2m) + deallocate(qvl1) deallocate(rswin) deallocate(swddni) deallocate(swddif) diff --git a/sorc/ncep_post.fd/DEWPOINT.f b/sorc/ncep_post.fd/DEWPOINT.f index 4284ecdbf..1b962871d 100644 --- a/sorc/ncep_post.fd/DEWPOINT.f +++ b/sorc/ncep_post.fd/DEWPOINT.f @@ -38,11 +38,12 @@ !> 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 ! @@ -50,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 @@ -127,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) @param[out] A Array with halos exchanged. !> !> ### Program history log: -!> Date | Programmer | Comments -!> -----|------------|--------- -!> 2000-01-06 | Jim Tuccillo | Initial +!> 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 @@ -19,40 +20,391 @@ 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) -! print *,'mype=',me,'in EXCH, after second mpi_sendrecv' + 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) + 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 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 e69a17a04..fbe110473 100644 --- a/sorc/ncep_post.fd/FDLVL.f +++ b/sorc/ncep_post.fd/FDLVL.f @@ -38,6 +38,7 @@ !> 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) @@ -51,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 @@ -63,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) @@ -87,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 @@ -101,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 @@ -119,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 @@ -430,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 @@ -491,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 @@ -501,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) @@ -519,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 @@ -536,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 @@ -818,7 +820,8 @@ SUBROUTINE FDLVL_MASS(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD) 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 @@ -836,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) @@ -860,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 @@ -868,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/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 2ef1fe7be..507e1d086 100644 --- a/sorc/ncep_post.fd/FRZLVL.f +++ b/sorc/ncep_post.fd/FRZLVL.f @@ -35,6 +35,7 @@ !> 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) @@ -45,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 @@ -53,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, & @@ -73,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 177e0cc2d..93e367513 100644 --- a/sorc/ncep_post.fd/FRZLVL2.f +++ b/sorc/ncep_post.fd/FRZLVL2.f @@ -39,6 +39,7 @@ !> 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 @@ -49,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 @@ -62,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, & @@ -76,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)= 0.) ) THEN pressure = 1000. diff --git a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f index e8fcdcc28..cca50d7b2 100644 --- a/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f +++ b/sorc/ncep_post.fd/INITPOST_GFS_NEMS_MPIIO.f @@ -76,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 ! @@ -355,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) diff --git a/sorc/ncep_post.fd/INITPOST_NETCDF.f b/sorc/ncep_post.fd/INITPOST_NETCDF.f index c7a7a2a3a..5a3018395 100644 --- a/sorc/ncep_post.fd/INITPOST_NETCDF.f +++ b/sorc/ncep_post.fd/INITPOST_NETCDF.f @@ -12,9 +12,11 @@ !> -----|------------|--------- !> 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 !> !> @author Hui-Ya Chuang @date 2016-03-04 SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) @@ -64,7 +66,8 @@ 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 + iSF_SURFACE_PHYSICS,rdaod, aqfcmaq_on, modelname, & + 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 @@ -147,11 +150,11 @@ SUBROUTINE INITPOST_NETCDF(ncid2d,ncid3d) 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 @@ -218,137 +221,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 @@ -358,14 +361,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 @@ -623,7 +629,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 @@ -634,7 +640,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 @@ -719,7 +725,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 @@ -742,13 +748,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 @@ -788,7 +794,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 @@ -799,13 +805,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 @@ -1569,14 +1576,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) 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) @@ -47,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 @@ -60,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 ! @@ -72,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 54f68fb9c..70ee6e438 100644 --- a/sorc/ncep_post.fd/LFMFLD_GFS.f +++ b/sorc/ncep_post.fd/LFMFLD_GFS.f @@ -39,6 +39,7 @@ !> 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) @@ -48,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 @@ -64,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 @@ -78,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 f2fdd6ea5..5d1ca0125 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 8aab37ba9..ccb2b5c43 100644 --- a/sorc/ncep_post.fd/MDL2P.f +++ b/sorc/ncep_post.fd/MDL2P.f @@ -29,6 +29,7 @@ !> 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) @@ -56,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 @@ -76,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 & @@ -85,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 ! @@ -100,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 @@ -118,6 +119,8 @@ SUBROUTINE MDL2P(iostatusD3D) ! ! START MDL2P. ! + if(me==0) print*, 'MDL2P SMFLAG=',SMFLAG + if (modelname == 'GFS') then zero = 0.0 else @@ -211,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 @@ -223,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 @@ -284,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. @@ -757,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) @@ -768,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) @@ -818,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) & @@ -842,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 @@ -892,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. ! @@ -927,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 @@ -985,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 @@ -998,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 @@ -1070,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 @@ -1102,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 @@ -1121,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 @@ -1138,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 @@ -1155,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 @@ -1176,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 @@ -1196,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 @@ -1223,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 @@ -1250,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 @@ -1279,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 @@ -1304,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) & @@ -1315,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 @@ -1332,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 @@ -1352,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 @@ -1369,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 @@ -1378,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 @@ -1395,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 @@ -1421,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 @@ -1438,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 @@ -1446,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 @@ -1461,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 @@ -1503,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 @@ -1526,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 @@ -1556,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 @@ -1582,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 @@ -1598,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 @@ -1644,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 @@ -1663,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 @@ -1675,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 @@ -1684,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 @@ -1701,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 @@ -1709,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 @@ -1725,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 @@ -1733,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 @@ -1749,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 @@ -1757,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 @@ -1773,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 @@ -1781,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 @@ -1798,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 @@ -1806,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 @@ -1822,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 @@ -1830,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 @@ -1846,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 @@ -1854,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 @@ -1870,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 @@ -1878,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 @@ -1892,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 @@ -1904,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 @@ -1923,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) @@ -1947,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 @@ -1962,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 @@ -1988,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 @@ -2004,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 @@ -2040,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 @@ -2055,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 @@ -2063,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 @@ -2078,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 @@ -2086,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 @@ -2101,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 @@ -2109,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 @@ -2124,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 @@ -2132,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 @@ -2151,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 @@ -2183,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 @@ -2198,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 @@ -2230,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 @@ -2245,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 @@ -2277,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 @@ -2292,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 @@ -2324,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 @@ -2339,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 @@ -2371,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 @@ -2386,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 @@ -2418,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 @@ -2433,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 @@ -2465,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 @@ -2480,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 @@ -2512,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 @@ -2527,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 @@ -2559,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 @@ -2574,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 @@ -2607,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 @@ -2622,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 @@ -2655,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 @@ -2670,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 @@ -2703,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 @@ -2718,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 @@ -2751,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 @@ -2766,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 @@ -2799,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 @@ -2814,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 @@ -2847,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 @@ -2862,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 @@ -2894,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 @@ -2909,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 @@ -2942,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 @@ -2957,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 @@ -2990,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 @@ -3005,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 @@ -3037,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 @@ -3052,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 @@ -3085,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 @@ -3100,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 @@ -3133,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 @@ -3148,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 @@ -3180,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 @@ -3195,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) & @@ -3233,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 @@ -3248,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 @@ -3281,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 @@ -3296,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 @@ -3329,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 @@ -3344,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 @@ -3377,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 @@ -3392,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 @@ -3425,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 @@ -3440,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 @@ -3473,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 @@ -3487,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 @@ -3523,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 @@ -3569,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 @@ -3613,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 @@ -3767,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 @@ -3783,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 @@ -3815,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 3dc0edb62..ee5ff8a94 100644 --- a/sorc/ncep_post.fd/MDL2STD_P.f +++ b/sorc/ncep_post.fd/MDL2STD_P.f @@ -11,6 +11,7 @@ !> 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() @@ -22,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 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! @@ -33,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 @@ -97,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 @@ -109,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 @@ -117,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 @@ -130,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 @@ -138,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 @@ -162,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 @@ -184,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 @@ -192,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 @@ -259,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) @@ -274,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)) @@ -289,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 @@ -308,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. @@ -334,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)) @@ -353,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 @@ -361,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 @@ -395,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 @@ -403,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 @@ -434,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 @@ -454,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 @@ -480,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 686139561..8d70c2ee4 100644 --- a/sorc/ncep_post.fd/MDL2THANDPV.f +++ b/sorc/ncep_post.fd/MDL2THANDPV.f @@ -16,6 +16,7 @@ !> 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) @@ -27,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 @@ -40,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 @@ -51,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 @@ -67,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. ! !--------------------------------------------------------------- @@ -98,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 @@ -113,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 @@ -130,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 @@ -154,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) @@ -176,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 @@ -211,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 @@ -220,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 @@ -249,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 @@ -284,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 @@ -336,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 @@ -350,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 @@ -389,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 @@ -429,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 @@ -465,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) @@ -482,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 @@ -559,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 @@ -652,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 @@ -661,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 @@ -710,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 @@ -718,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 @@ -733,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 @@ -752,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 @@ -769,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 @@ -777,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 @@ -794,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 @@ -802,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 @@ -819,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 @@ -831,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 @@ -848,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 @@ -856,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 @@ -874,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 @@ -887,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 @@ -914,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 @@ -926,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 @@ -942,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 @@ -954,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 @@ -970,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 @@ -982,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 @@ -998,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 @@ -1010,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 @@ -1025,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 c333ad586..84417aaf2 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 @@ -3282,7 +3385,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) @@ -3297,11 +3400,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 @@ -3313,13 +3417,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 @@ -3333,11 +3437,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 @@ -3349,7 +3454,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 @@ -3357,11 +3462,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 @@ -3369,7 +3475,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 @@ -3377,11 +3483,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 @@ -3394,7 +3501,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 @@ -3405,11 +3512,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 @@ -3420,7 +3528,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) @@ -3435,11 +3543,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 @@ -3453,13 +3562,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. @@ -3477,7 +3586,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 @@ -3496,7 +3605,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 @@ -3541,7 +3650,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, & @@ -3587,7 +3696,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 @@ -3621,7 +3730,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 @@ -3630,11 +3739,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 @@ -3645,7 +3755,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 @@ -3654,7 +3764,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 @@ -3663,11 +3773,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 @@ -3679,7 +3790,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 @@ -3688,11 +3799,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 @@ -3701,10 +3813,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 @@ -3722,7 +3834,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 @@ -3730,7 +3842,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 @@ -3747,7 +3859,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, & @@ -3765,7 +3877,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 @@ -3774,11 +3886,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 @@ -3791,14 +3904,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 @@ -3808,7 +3921,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) @@ -3817,7 +3930,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) @@ -3838,8 +3951,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 @@ -3849,8 +3962,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 @@ -3860,13 +3973,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) @@ -3885,7 +3998,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) @@ -4151,7 +4273,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 @@ -4164,7 +4286,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 @@ -4202,11 +4324,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 @@ -4215,7 +4338,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 @@ -4244,11 +4367,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 @@ -4259,7 +4383,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 @@ -4287,7 +4411,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 @@ -4296,11 +4420,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 @@ -4311,7 +4436,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 @@ -4319,11 +4444,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 @@ -4333,7 +4459,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 @@ -4352,11 +4478,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 @@ -4371,7 +4498,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. @@ -4382,11 +4509,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 @@ -4398,7 +4526,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 @@ -4407,11 +4535,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 @@ -4423,7 +4552,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 @@ -4432,11 +4561,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 @@ -4464,7 +4594,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 @@ -4473,11 +4603,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 @@ -4517,15 +4648,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/NGMFLD.f b/sorc/ncep_post.fd/NGMFLD.f index 39ae45cb1..2d7052e35 100644 --- a/sorc/ncep_post.fd/NGMFLD.f +++ b/sorc/ncep_post.fd/NGMFLD.f @@ -40,6 +40,7 @@ !> 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) @@ -51,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 @@ -62,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, & @@ -76,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 @@ -103,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) @@ -112,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. @@ -186,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) 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) @@ -31,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 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -42,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 @@ -60,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 @@ -68,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 f74992a0b..2270113da 100644 --- a/sorc/ncep_post.fd/OTLIFT.f +++ b/sorc/ncep_post.fd/OTLIFT.f @@ -20,6 +20,7 @@ !> 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) @@ -30,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 ! @@ -43,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 @@ -60,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) irank ) iend = iend + 1 return end +!! +!! USAGE: CALL PARA_RANGE2(N1,N2,NX,NY,NRANK,ISTA,IEND,JSTA,JEND)(A) +!! INPUT ARGUMENT LIST: +!! 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 I +!! IEND - LAST LOOP VALUE I +!! JSTA - FIRST LOOP VALUE J +!! JEND - LAST LOOP VALUE J +!! +!! OUTPUT FILES: +!! STDOUT - RUN TIME STANDARD OUT. +!! +!! SUBPROGRAMS CALLED: +!! UTILITIES: +!! NONE +!! LIBRARY: +!! +!! ATTRIBUTES: +!! LANGUAGE: FORTRAN +!! MACHINE : IBM RS/6000 SP +!! + subroutine para_range2(im,jm,nx,ny,nrank,ista,iend,jsta,jend) + + implicit none + 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 + diff --git a/sorc/ncep_post.fd/PROCESS.f b/sorc/ncep_post.fd/PROCESS.f index 8facc7d80..64c9c35de 100644 --- a/sorc/ncep_post.fd/PROCESS.f +++ b/sorc/ncep_post.fd/PROCESS.f @@ -53,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, @@ -91,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, @@ -98,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 21d4e41d6..4450bb9f4 100644 --- a/sorc/ncep_post.fd/SCLFLD.f +++ b/sorc/ncep_post.fd/SCLFLD.f @@ -20,6 +20,7 @@ !> -----|------------|--------- !> 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) @@ -27,7 +28,7 @@ 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 ! @@ -35,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 ! ! @@ -46,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/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 @@ -793,11 +820,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(501)) 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) = PSFCAVG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = PSFCAVG(ii,jj) enddo enddo endif @@ -822,11 +850,12 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(502)) 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) = T10AVG(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = T10AVG(ii,jj) enddo enddo endif @@ -836,7 +865,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 @@ -865,7 +894,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 ! @@ -873,7 +902,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) @@ -888,23 +917,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 @@ -913,11 +943,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 @@ -927,11 +958,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 @@ -941,11 +973,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 @@ -967,10 +1000,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 @@ -996,11 +1029,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 @@ -1010,11 +1044,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 @@ -1024,7 +1059,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 @@ -1032,7 +1067,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 @@ -1040,11 +1075,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 @@ -1054,11 +1090,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 @@ -1078,11 +1115,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 @@ -1116,11 +1154,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 @@ -1154,11 +1193,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 @@ -1192,7 +1232,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 @@ -1224,7 +1264,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 @@ -1232,11 +1272,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 @@ -1246,11 +1287,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 @@ -1260,11 +1302,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 @@ -1273,7 +1316,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 @@ -1301,11 +1344,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 @@ -1314,7 +1358,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 @@ -1342,11 +1386,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 @@ -1355,7 +1400,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 @@ -1383,11 +1428,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 @@ -1401,7 +1447,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 @@ -1436,7 +1482,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 ! @@ -1453,12 +1499,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) @@ -1475,7 +1521,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 @@ -1484,12 +1530,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 ! @@ -1497,21 +1543,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 @@ -1519,30 +1565,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 @@ -1564,14 +1610,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) @@ -1579,7 +1625,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 @@ -1587,7 +1633,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 @@ -1596,16 +1642,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 @@ -1613,7 +1659,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 !------------------------------------------------------------------------- @@ -1623,7 +1669,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)) @@ -1643,7 +1689,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 @@ -1651,7 +1697,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 @@ -1661,10 +1707,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) @@ -1678,12 +1724,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 @@ -1696,11 +1742,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 @@ -1710,7 +1757,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 @@ -1787,7 +1836,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 @@ -1821,11 +1870,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 @@ -1835,7 +1885,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 @@ -1867,11 +1917,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 @@ -1881,7 +1932,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 @@ -1919,11 +1970,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 @@ -1933,7 +1985,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 @@ -1969,11 +2021,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 @@ -2009,11 +2062,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 @@ -2048,11 +2102,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 @@ -2063,7 +2118,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 @@ -2071,7 +2126,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 ! @@ -2084,7 +2139,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 @@ -2092,20 +2147,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 @@ -2114,7 +2171,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 @@ -2130,7 +2187,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 !--- @@ -2138,7 +2195,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 @@ -2153,14 +2210,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 @@ -2175,14 +2232,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 @@ -2197,14 +2254,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 @@ -2219,7 +2276,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 ! @@ -2234,7 +2291,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 @@ -2244,22 +2301,24 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(506)) 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 cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(507)) 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) = GRID2(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID2(ii,jj) enddo enddo endif @@ -2272,18 +2331,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 @@ -2294,18 +2354,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 @@ -2316,18 +2377,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 @@ -2340,7 +2402,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 @@ -2353,11 +2415,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 @@ -2368,7 +2431,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 @@ -2381,11 +2444,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 @@ -2396,7 +2460,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 @@ -2409,10 +2473,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 @@ -2427,10 +2492,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 @@ -2445,11 +2510,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 @@ -2475,7 +2541,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 @@ -2486,11 +2552,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 @@ -2504,7 +2571,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 @@ -2512,11 +2579,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 @@ -2530,7 +2598,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. @@ -2543,11 +2611,12 @@ SUBROUTINE SURFCE if(grib=='grib2') then cfld=cfld+1 fld_info(cfld)%ifld=IAVBLFLD(IGET(167)) -!$omp parallel do private(i,j,jj) +!$omp parallel do private(i,j,ii,jj) do j=1,jend-jsta+1 jj = jsta+j-1 - do i=1,im - datapd(i,j,cfld) = GRID1(i,jj) + do i=1,iend-ista+1 + ii = ista+i-1 + datapd(i,j,cfld) = GRID1(ii,jj) enddo enddo endif @@ -2558,7 +2627,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 @@ -2572,11 +2641,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 @@ -2587,7 +2657,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 @@ -2601,11 +2671,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 @@ -2638,7 +2709,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 @@ -2657,11 +2728,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 @@ -2695,7 +2767,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 @@ -2711,11 +2783,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 @@ -2746,7 +2819,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 @@ -2756,7 +2829,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 @@ -2767,7 +2840,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 @@ -2789,11 +2862,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 @@ -2840,7 +2914,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 @@ -2858,11 +2932,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 @@ -2895,7 +2970,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 @@ -2906,7 +2981,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 @@ -2917,7 +2992,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 @@ -2932,11 +3007,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 @@ -2982,7 +3058,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 @@ -2999,11 +3075,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 @@ -3037,7 +3114,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 @@ -3048,7 +3125,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 @@ -3060,7 +3137,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 @@ -3071,11 +3148,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 @@ -3086,8 +3164,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 @@ -3121,7 +3200,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 @@ -3139,11 +3218,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 @@ -3155,7 +3235,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 @@ -3190,11 +3270,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 @@ -3204,7 +3285,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 @@ -3235,11 +3316,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 @@ -3249,7 +3331,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 @@ -3279,11 +3361,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 @@ -3293,7 +3376,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 @@ -3323,11 +3406,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 @@ -3337,7 +3421,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 @@ -3368,11 +3452,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 @@ -3382,7 +3467,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 @@ -3413,11 +3498,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 @@ -3427,7 +3513,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 @@ -3466,11 +3552,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 @@ -3480,7 +3567,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 @@ -3519,11 +3606,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 @@ -3533,7 +3621,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 @@ -3566,11 +3654,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 @@ -3581,7 +3670,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 @@ -3628,11 +3717,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 @@ -3643,7 +3733,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 @@ -3697,11 +3787,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 @@ -3711,7 +3802,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 @@ -3758,11 +3849,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 @@ -3772,7 +3864,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 @@ -3816,11 +3908,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 @@ -3830,7 +3923,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 @@ -3874,11 +3967,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 @@ -4022,7 +4116,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 @@ -4042,11 +4136,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 @@ -4055,7 +4150,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 @@ -4075,11 +4170,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 @@ -4088,7 +4184,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 @@ -4108,11 +4204,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 @@ -4121,7 +4218,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 @@ -4142,11 +4239,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 @@ -4155,7 +4253,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 @@ -4176,11 +4274,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 @@ -4190,9 +4289,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' @@ -4200,7 +4299,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 @@ -4251,7 +4351,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 @@ -4264,7 +4364,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' @@ -4274,7 +4374,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 @@ -4290,7 +4390,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 @@ -4306,7 +4406,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 @@ -4316,7 +4416,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 @@ -4325,27 +4425,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 @@ -4353,18 +4454,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 @@ -4372,7 +4474,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) @@ -4385,11 +4487,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 @@ -4397,18 +4500,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 @@ -4418,16 +4522,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 @@ -4774,7 +4882,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 @@ -4895,7 +5003,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 @@ -4912,7 +5020,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 @@ -4926,25 +5034,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 @@ -4954,18 +5063,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) @@ -4976,29 +5086,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 @@ -5027,7 +5139,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 @@ -5062,7 +5174,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 @@ -5080,7 +5192,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 @@ -5116,7 +5228,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 ! @@ -5134,7 +5246,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 @@ -5166,7 +5278,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 ! @@ -5184,7 +5296,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 @@ -5216,7 +5328,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 ! @@ -5233,7 +5345,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 @@ -5269,7 +5381,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 ! @@ -5287,7 +5399,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 @@ -5319,7 +5431,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 ! @@ -5337,7 +5449,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 @@ -5369,7 +5481,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 ! @@ -5377,7 +5489,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 @@ -5411,7 +5523,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 @@ -5420,7 +5532,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 @@ -5454,35 +5566,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 ! @@ -5490,41 +5602,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 ! @@ -5534,14 +5646,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 @@ -5549,14 +5661,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 @@ -5566,13 +5678,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 @@ -5584,14 +5696,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 @@ -5602,7 +5714,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 @@ -5613,7 +5725,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 @@ -5644,14 +5756,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 @@ -5682,7 +5794,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 @@ -5695,14 +5807,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 @@ -5710,7 +5822,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 ! @@ -5722,14 +5834,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 @@ -5737,21 +5849,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 ! @@ -5759,14 +5871,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 @@ -5775,14 +5887,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 ! @@ -5790,14 +5902,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 ! @@ -5807,7 +5919,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 @@ -5818,7 +5930,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 @@ -5827,54 +5939,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' @@ -5890,10 +6002,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 @@ -5936,118 +6048,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 @@ -6069,7 +6181,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)) @@ -6081,11 +6193,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 @@ -6094,7 +6207,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)) @@ -6106,11 +6219,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 @@ -6119,7 +6233,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 @@ -6150,11 +6264,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 @@ -6163,7 +6278,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 @@ -6194,11 +6309,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 @@ -6210,21 +6326,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 @@ -6241,14 +6357,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 @@ -6265,7 +6381,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 @@ -6273,7 +6389,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 @@ -6291,14 +6407,14 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(503)) fld_info(cfld)%ntrange=IFHR-ID(18) fld_info(cfld)%tinvstat=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 ! 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 @@ -6316,7 +6432,7 @@ SUBROUTINE SURFCE fld_info(cfld)%ifld=IAVBLFLD(IGET(504)) fld_info(cfld)%ntrange=IFHR-ID(18) fld_info(cfld)%tinvstat=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 @@ -6330,7 +6446,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 @@ -6349,7 +6466,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) @@ -6392,7 +6509,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 @@ -6444,11 +6561,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 9678afcf8..24a27d71d 100644 --- a/sorc/ncep_post.fd/TRPAUS.f +++ b/sorc/ncep_post.fd/TRPAUS.f @@ -29,6 +29,7 @@ !> 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) @@ -40,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 ! @@ -65,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 @@ -80,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 5ccb2c9ad..7ea734f58 100644 --- a/sorc/ncep_post.fd/TRPAUS_NAM.f +++ b/sorc/ncep_post.fd/TRPAUS_NAM.f @@ -29,6 +29,7 @@ !> 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) @@ -52,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 @@ -65,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 @@ -80,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 58f74fa14..28da9b87a 100644 --- a/sorc/ncep_post.fd/UPP_MATH.f +++ b/sorc/ncep_post.fd/UPP_MATH.f @@ -17,7 +17,8 @@ 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 @@ -41,7 +42,7 @@ 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 !-- @@ -52,7 +53,7 @@ subroutine dvdxdudy(uwnd,vwnd) IF(GRIDTYPE == 'A')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 IF(VWND(I+1,J)= 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 @@ -170,40 +171,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 @@ -216,39 +218,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 @@ -261,40 +264,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 e19191de2..239cbde7a 100644 --- a/sorc/ncep_post.fd/UPP_PHYSICS.f +++ b/sorc/ncep_post.fd/UPP_PHYSICS.f @@ -31,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 @@ -43,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) @@ -90,7 +94,7 @@ END SUBROUTINE CALRH !> @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 ! @@ -98,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 !*************************************************************** @@ -108,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)) @@ -170,7 +174,7 @@ END SUBROUTINE CALRH_NAM !> @author Russ Treadon W/NP2 @date 1992-12-22 SUBROUTINE CALRH_GFS(P1,T1,Q1,RH) use params_mod, only: rhmin - use ctlblk_mod, only: jsta, jend, spval, im + use ctlblk_mod, only: ista, iend, jsta, jend, spval !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! @@ -187,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 !*************************************************************** @@ -197,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 @@ -237,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 @@ -279,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 @@ -296,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) 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 @@ -762,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 @@ -780,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 @@ -805,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 @@ -818,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 @@ -826,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 @@ -837,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 @@ -847,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 @@ -878,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 @@ -1007,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 @@ -1019,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 @@ -1046,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 ! @@ -1078,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 @@ -1106,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 @@ -1122,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 @@ -1133,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 @@ -1144,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) @@ -1175,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 @@ -1192,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) @@ -1288,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 @@ -1299,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 @@ -1323,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 @@ -1341,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 @@ -1366,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 @@ -1378,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 @@ -1386,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 @@ -1402,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 @@ -1413,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 @@ -1474,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 @@ -1485,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 @@ -1513,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))) @@ -1533,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 @@ -1553,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 @@ -1563,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 @@ -1585,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 @@ -1601,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 @@ -1609,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.) @@ -1625,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. @@ -1662,5 +1668,967 @@ 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 +!> +!> @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(VWND(I+1,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/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 f6a60daf2..63aa39c9e 100644 --- a/sorc/ncep_post.fd/WETFRZLVL.f +++ b/sorc/ncep_post.fd/WETFRZLVL.f @@ -25,6 +25,7 @@ !> 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) @@ -35,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 @@ -55,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 3d895c5c0..c670150f9 100644 --- a/sorc/ncep_post.fd/WRFPOST.f +++ b/sorc/ncep_post.fd/WRFPOST.f @@ -23,6 +23,7 @@ !> 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 @@ -109,11 +110,12 @@ PROGRAM WRFPOST 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, 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, & 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 @@ -139,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 @@ -186,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) @@ -194,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 @@ -201,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) @@ -265,12 +270,49 @@ PROGRAM WRFPOST fileNameFlat='postxconfig-NT.txt' 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 @@ -652,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/grib2_module.f b/sorc/ncep_post.fd/grib2_module.f index 35c064c53..01561b6ed 100644 --- a/sorc/ncep_post.fd/grib2_module.f +++ b/sorc/ncep_post.fd/grib2_module.f @@ -10,6 +10,7 @@ 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 !------------------------------------------------------------------------ use xml_perl_data, only: param_t,paramset_t ! @@ -197,7 +198,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 +216,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 +255,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 +277,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 +348,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